Library sset9

Theory of Sets EIII-5 Properties of integers

Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Export sset8.

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

Ltac cotac1 := match goal with
    | Ha: inc ?b Bnat, Hb: ?a <c (succ ?b) |- ?a <=c ?b
     => by apply /(card_lt_succ_leP Ha)
    | Ha: inc ?b Bnat, Hb: ?a <=c ?b |- ?a <c (succ ?b)
     => by apply /(card_lt_succ_leP Ha)
    | Ha: inc ?a Bnat, Hb: succ ?a <=c ?b |- ?a <c ?b
     => by apply /(card_le_succ_ltP _ Ha)
    | Ha: inc ?a Bnat, Hb: ?a <c ?b |- succ ?a <=c ?b
     => by apply /(card_le_succ_ltP _ Ha)
end.

Module IntegerProps.

EIII-5-1 Operations on integers and finite sets

Functions on nat

Lemma Bsum_M0le a b: inc a Bnat -> inc b Bnat->
  a <=c (a +c b ).
Proof. move=> ca cb; apply: csum_M0le; fprops. Qed.

Lemma Bprod_M1le a b: inc a Bnat -> inc b Bnat->
   b <> \0 c -> a <=c (a *c b ).
Proof. move=> ca cb; apply: cprod_M1le; fprops. Qed.

Lemma Bnat_to_ell a b: inc a Bnat -> inc b Bnat ->
  [\/ a = b, a <c b | b <c a].
Proof. move=> aB bB; apply: card_le_to_ell; fprops. Qed.

Lemma Bnat_to_el a b: inc a Bnat -> inc b Bnat ->
  a <=c b \/ b <c a.
Proof. move=> aB bB; apply: card_le_to_el; fprops. Qed.

Lemma Bnat_to_ee a b: inc a Bnat -> inc b Bnat ->
  a <=c b \/ b <=c a.
Proof. move=> aB bB; apply: card_le_to_ee; fprops. Qed.

Lemma csum_trivial4 f a:
  card_sum (restr f (singleton a)) = cardinal (Vg f a).
Proof.
have <-: Vg (restr f (singleton a)) a = Vg f a by bw; fprops.
apply: csum_trivial2; rewrite restr_d //.
Qed.

Lemma cprod_trivial4 f a:
  card_prod (restr f (singleton a)) = cardinal (Vg f a).
Proof.
have <-: Vg (restr f (singleton a)) a = Vg f a by bw ; fprops.
apply: cprod_trivial2; rewrite restr_d //.
Qed.

Lemma csum_increasing6 f j: cardinal_fam f ->
  inc j (domain f) -> (Vg f j ) <=c (card_sum f ).
Proof.
move=> cf jd.
move: (csum_increasing1 cf (set1_sub jd)).
by rewrite csum_trivial4 (card_card (cf _ jd)).
Qed.

Lemma cprod_increasing6 f j: cardinal_fam f -> card_nz_fam f ->
  inc j (domain f) -> (Vg f j ) <=c (card_prod f ).
Proof.
move=> cf alnz jd.
move: (cprod_increasing1 cf alnz (set1_sub jd)).
by rewrite cprod_trivial4 (card_card (cf _ jd)).
Qed.

Lemma induction_sum0 f a b: (~ inc b a) ->
  card_sum (restr f (a +s1 b)) =
  card_sum (restr f a) +c (Vg f b ).
Proof. move => nba; exact: (csumA_setU1 (Vg f) nba). Qed.

Lemma induction_prod0 f a b: (~ inc b a) ->
  card_prod (restr f (a +s1 b)) =
  (card_prod (restr f a)) *c (Vg f b ) .
Proof. move => nba; exact: (cprodA_setU1 (Vg f) nba). Qed.

Lemma induction_sum1 f a b:
  domain f = a +s1 b -> (~ inc b a) ->
  card_sum f = card_sum (restr f a) +c (Vg f b ).
Proof.
by move=> df nba; rewrite - (induction_sum0 _ nba) -df card_sum_gr.
Qed.

Lemma induction_prod1 f a b:
  domain f = a +s1 b -> (~ inc b a) ->
  card_prod f = card_prod (restr f a) *c (Vg f b ).
Proof.
by move=> df nba; rewrite - (induction_prod0 _ nba) - df - card_prod_gr.
Qed.

Definition of a finite family of integers

Definition finite_int_fam f:=
(allf f (inc ^~Bnat)) /\ finite_set (domain f).

A finite sum or product of integers is an integer

Section FiniteIntFam.
Variable f: Set.
Hypothesis fif: finite_int_fam f.

Lemma finite_sum_finite_aux x:
  sub x (domain f) -> inc (card_sum (restr f x)) Bnat.
Proof.
move: fif => [alB fsd] sxd.
move: (sub_finite_set sxd fsd) => fsx.
move: x fsx sxd.
apply: finite_set_induction0.
  move=> _;rewrite csum_trivial; fprops; bw; fprops.
move=> a b ap nba st.
move: (alB _ (st _ (setU1_1 b a))) => vb.
rewrite induction_sum0 =>//.
apply: BS_sum =>//; apply: ap; apply: sub_trans st; fprops.
Qed.

Lemma finite_product_finite_aux x:
  sub x (domain f) -> inc (card_prod (restr f x)) Bnat.
Proof.
move: fif => [alB fsd] sxd.
have fsx:=(sub_finite_set sxd fsd).
move: x fsx sxd.
apply: finite_set_induction0.
  rewrite cprod_trivial;fprops; bw; fprops.
move=> a b ap nba st.
rewrite induction_prod0 =>//.
have ha:= (@sub_setU1 b a) ; have hb:= (setU1_1 b a).
exact: (BS_prod (ap (sub_trans ha st)) (alB _ (st _ hb))).
Qed.

Theorem finite_sum_finite: inc (card_sum f) Bnat.
Proof.
rewrite - card_sum_gr;apply: finite_sum_finite_aux;fprops.
Qed.

Theorem finite_product_finite: inc (card_prod f) Bnat.
Proof.
rewrite - card_prod_gr; apply: finite_product_finite_aux; fprops.
Qed.

End FiniteIntFam.

Finite unions and products of finite sets are finite sets

Lemma finite_union_finite f:
  (allf f finite_set) -> finite_set (domain f) -> finite_set (unionb f).
Proof.
move=> alf fsd.
set (g:= Lg (domain f) (fun a => cardinal (Vg f a))).
have dg: (domain g = domain f) by rewrite /g; bw.
have fif: (finite_int_fam g).
  split => //; last by ue.
    rewrite /g;fprops.
  by red; rewrite dg /g; move=> i idf; bw;apply /BnatP; apply: alf.
move: (csum_pr1 f) (finite_sum_finite fif) ; rewrite -/g => f2 xB.
by apply/card_finite_setP; apply: (BS_le_int f2).
Qed.

Lemma finite_product_finite_set f: (allf f finite_set)
  -> finite_set (domain f) -> finite_set(productb f).
Proof.
move=> alf fsd.
set (g:= Lg (domain f) (fun a => cardinal (Vg f a))).
have dg: (domain g = domain f) by rewrite /g;bw.
red;rewrite cprod_pr//; apply: Bnat_hi.
apply: finite_product_finite; split => //;last by ue.
by red; bw; move=> i idf; bw; apply /BnatP;apply: alf.
Qed.

EIII-5-2 Strict inequalities between integers

If a<b there is a strictly positive c such that c=a*b

Lemma strict_pos_P1 a: inc a Bnat ->
  (a <> \0 c <-> \0 c <c a).
Proof.
move => aB; split => h; first by apply : card_ne0_pos; fprops.
by move: h => [_ /nesym].
Qed.

Lemma strict_pos_P a: inc a Bnat ->
  (\0 c <> a <-> \0 c <c a).
Proof.
by move => aB; apply:(iff_trans _ (strict_pos_P1 aB)); split; apply nesym.
Qed.

Theorem card_ltP a b: inc a Bnat -> inc b Bnat ->
  (a <c b <-> exists c, [/\ inc c Bnat, c <> \0 c & a +c c = b]).
Proof.
move=> aB bB; split.
  move=> [ab nab]; move: (BS_diff a bB) => pa; ex_tac.
    by apply: cdiff_nz.
  by rewrite (cardinal_setC1 ab).
move=> [c [cB cnz <-]].
move: (card_lt_succ aB); rewrite (Bsucc_rw aB) => asa.
have p2: (a +c \1 c ) <=c (a +c c).
   apply: csum_Mlele; fprops; apply: card_ge1; fprops.
co_tac.
Qed.

Compatibility of sum and product with strict order

Lemma csum_Mlelt a b a' b':
  inc a' Bnat -> inc b' Bnat->
  a <=c a' -> b <c b' -> (a +c b ) <c (a' +c b').
Proof.
move=> a'B b'B aa' bb'.
have bB: inc b Bnat by Bnat_tac.
move/ (card_ltP bB b'B):bb' => [c [cB cnz <-]].
apply: (@card_le_ltT _ (a' +c b)).
   apply: csum_Mlele; fprops.
by rewrite csumA; apply card_ltP;fprops; exists c.
Qed.

Lemma csum_Mlteq a a' b:
  inc b Bnat -> inc a' Bnat ->
  a <c a' -> (a +c b ) <c (a'+c b ).
Proof.
move=> bB a'B aa'; rewrite csumC (csumC a' b); apply: csum_Mlelt; fprops.
Qed.

Lemma csum_Meqlt a a' b:
  inc b Bnat -> inc a' Bnat ->
  a <c a' -> (b +c a ) <c (b +c a').
Proof.
by rewrite (csumC b) (csumC b); exact:csum_Mlteq.
Qed.

Lemma csum_M0lt a b: inc a Bnat -> inc b Bnat -> \0 c <c b -> a <c a +c b.
Proof.
move => aB bB bp.
rewrite -{1} (csum0r (CS_Bnat aB)); apply:csum_Meqlt => //.
Qed.
Lemma finite_sum4_lt a b: inc b Bnat ->
   a <> \0 c -> b <c (b +c a ).
Proof.
move=> bB anz.
rewrite - csum2_pr2b.
have az: \0 c <c cardinal a.
  split; first by apply: czero_least; fprops.
  by apply: nesym;apply:cardinal_nonemptyset0.
rewrite csumC.
move: (CS_Bnat bB) => cb.
case: (finite_dichot (CS_cardinal a)).
  move /BnatP => aB; move: (csum_Mlteq bB aB az); aw.
move => ia.
apply: card_lt_leT (csum_M0le b (proj1 ia)).
apply: finite_lt_infinite; fprops.
Qed.

Lemma cprod_Mlelt a b a' b':
  inc a' Bnat -> inc b' Bnat->
  a <=c a' -> b <c b' -> a' <> \0 c ->
  (a *c b ) <c (a' *c b').
Proof.
move=> a'B b'B aa' bb'.
have bB: inc b Bnat by Bnat_tac.
move /(card_ltP bB b'B):bb' => [c [cB cnz <-]] anz.
apply: (@card_le_ltT _ (a' *c b)).
  apply: cprod_Mlele; fprops.
move: (BS_prod a'B cB) => pB.
rewrite cprod_sumDl; apply /card_ltP; fprops;ex_tac.
by apply: cprod2_nz.
Qed.

Theorem finite_sum_lt f g:
  finite_int_fam f -> finite_int_fam g -> domain f = domain g ->
  (forall i, inc i (domain f) -> (Vg f i ) <=c (Vg g i )) ->
  (exists2 i, inc i (domain f) & (Vg f i) <c (Vg g i)) ->
  (card_sum f ) <c (card_sum g ).
Proof.
move=> fif fig df ale [i ifg lti].
move: (fif)(fig)=> [f2 f3] [g2 g3].
have idg: inc i (domain g) by rewrite -df.
move: (setC1_K ifg) => dtc; symmetry in dtc.
have incd: ~ (inc i (complement (domain f) (singleton i))).
  by move=> /setC1_P [_ ]; aw => aux; case: aux.
have sd: sub ((domain f) -s1 i) (domain f) by apply: sub_setC.
have sdg: sub ((domain g) -s1 i) (domain g) by apply: sub_setC.
rewrite (induction_sum1 dtc incd).
rewrite df in dtc incd; rewrite (induction_sum1 dtc incd).
have afB: inc (Vg f i) Bnat by apply: f2.
have agB: inc (Vg g i) Bnat by apply: g2.
apply: csum_Mlelt =>//.
  apply: finite_sum_finite_aux=>//.
apply: csum_increasing;fprops; bw; first by ue.
move=> x xd; bw; rewrite - ?df;fprops.
Qed.

Theorem finite_product_lt f g:
  finite_int_fam f -> finite_int_fam g -> domain f = domain g ->
  (forall i, inc i (domain f) -> (Vg f i ) <=c (Vg g i )) ->
  (exists2 i, inc i (domain f) & (Vg f i) <c (Vg g i)) ->
  card_nz_fam g ->
  (card_prod f ) <c (card_prod g ).
Proof.
move=> fif fig df ale [i ifg lti] alne.
move: (fif)(fig)=> [f2 f3] [g2 g3].
have idg: inc i (domain g) by rewrite -df.
have afB: inc (Vg f i) Bnat by apply: f2.
have agB: inc (Vg g i) Bnat by apply: g2.
have sd: sub ((domain f) -s1 i) (domain f) by apply: sub_setC.
have sdg: sub ((domain g) -s1 i) (domain g) by apply: sub_setC.
have incd: ~ (inc i ((domain f) -s1 i)).
  by move=> /setC1_P [_ ]; aw => aux; case: aux.
move: (setC1_K ifg) => dtc; symmetry in dtc.
rewrite (induction_prod1 dtc incd).
rewrite df in dtc incd; rewrite (induction_prod1 dtc incd).
apply: cprod_Mlelt =>//.
      apply: finite_product_finite_aux=>//.
  apply: cprod_increasing;fprops; bw; first by ue.
  move=> x xd; bw=>//; rewrite - ?df;fprops.
apply/cprod_nzP; fprops.
red;rewrite restr_d; fprops.
move=> j jdg; move: (jdg) => /setC1_P [jd _]; bw;apply: (alne _ jd).
Qed.

Lemma cprod_M1lt a b: inc a Bnat -> inc b Bnat ->
  a <> \0 c -> \1 c <c b -> a <c (a *c b ).
Proof.
move=> aB bB naz c1b.
move: (CS_Bnat aB) => ca.
move: (cprod_Mlelt aB bB (card_leR ca) c1b naz).
by rewrite cprod1r.
Qed.

Compatibility of power and order

Lemma cpow_nz a b: a <> \0 c -> (a ^c b ) <> \0 c.
Proof.
move=> anz;rewrite - cpow_pr2; apply /cprod_nzP ; red; bw => t tb; bw.
Qed.

Lemma cpow2_nz x: \2 c ^c x <> \0 c.
Proof. apply: cpow_nz; fprops. Qed.

Lemma cpow_Mltle a a' b:
  inc a' Bnat -> inc b Bnat->
  a <c a' -> b <> \0 c -> (a ^c b ) <c (a' ^c b ).
Proof.
move=> a'B bB aa' nzb.
move: (cpred_pr bB nzb) => [pB bs].
have nza': a'<> \0 c.
  by move => h; rewrite h in aa'; apply: (card_lt0 aa').
case: (equal_or_not a \0 c).
  move=> ->; rewrite cpow0x //; split.
    move: (BS_pow a'B bB) => poB; apply: czero_least; fprops.
  apply: nesym; apply: cpow_nz;fprops.
move => nz.
rewrite bs (pow_succ a pB)(pow_succ a' pB).
have p1: a <=c a' by move: aa' => [ok _].
have p2: (cpred b) <=c (cpred b) by fprops.
move: (BS_pow a'B pB) => ca'.
move: (cpow_Mlele nz p1 p2) => p3.
apply: (cprod_Mlelt ca' a'B p3 aa').
apply: cpow_nz;fprops.
Qed.

Lemma cpow_Mlelt a b b':
  inc a Bnat -> inc b' Bnat->
  b <c b' -> \1 c <c a -> (a ^c b ) <c (a ^c b').
Proof.
move=> aB b'B bb' l1a.
have anz: a <> \0 c by move: l1a=> [/card_ge1P [_ /nesym h] _].
have bB: inc b Bnat by Bnat_tac.
move: bb' => /(card_ltP bB b'B) [c [cB cnz <-]].
have ca:cardinalp a by fprops.
move:(cpow_Mle1 ca cnz) => le1.
rewrite cpow_sum2; apply: cprod_M1lt; fprops.
  apply: cpow_nz; fprops.
co_tac.
Qed.

Lemma cpow_M1lt a b: cardinalp a -> \1 c <c b -> a <c (b ^c a ).
Proof.
move => ca [ /card_ge1P [ww /nesym h] bn1].
apply(card_lt_leT (cantor ca)).
apply: cpow_Mlele; fprops;apply: card_ge2; fprops;co_tac.
Qed.

Injectivity of sum and product

Lemma csum_simplifiable_left a b b':
  inc a Bnat -> inc b Bnat -> inc b' Bnat ->
  a +c b = a +c b' -> b = b'.
Proof.
move=> aB bB bB' eql.
have laa: a <=c a by fprops.
case: (Bnat_to_ell bB bB') =>// aux.
  by move: (csum_Mlelt aB bB' laa aux)=> [_ h].
by move: (csum_Mlelt aB bB laa aux)=> [_ []].
Qed.

Lemma csum_simplifiable_right a b b':
  inc a Bnat -> inc b Bnat -> inc b' Bnat ->
  b +c a = b' +c a -> b = b'.
Proof.
move=> aB bB b'B;
rewrite csumC (csumC b' a).
by apply: csum_simplifiable_left.
Qed.

Lemma cprod_simplifiable_left a b b':
  inc a Bnat -> inc b Bnat -> inc b' Bnat ->
  a <> \0 c -> a *c b = a *c b' -> b = b'.
Proof.
move=> aB bB bB' naz eql.
have laa: a <=c a by fprops.
case: (Bnat_to_ell bB bB') =>// aux.
  by move: (cprod_Mlelt aB bB' laa aux naz)=> [_ h].
by move: (cprod_Mlelt aB bB laa aux naz)=> [_ []].
Qed.

Lemma cprod_simplifiable_right a b b':
  inc a Bnat -> inc b Bnat -> inc b' Bnat ->
  a <> \0 c -> b *c a = b' *c a -> b = b'.
Proof.
by move=> aB bB b'B;rewrite cprodC (cprodC b' a);apply: cprod_simplifiable_left.
Qed.

cardinal difference

Lemma cdiff_wrong a b: a <=c b -> a -c b = \0 c.
Proof.
by move => [_ _ ab]; rewrite /card_diff (setC_T ab) cardinal_set0.
Qed.

Lemma cdiff_pr a b:
  b <=c a -> b +c (a -c b ) = a.
Proof. apply: cardinal_setC1. Qed.

Lemma cdiff_pr0 a b: inc a Bnat-> inc b Bnat ->
  b <=c a -> (inc (a -c b) Bnat /\ b +c (a -c b ) = a).
Proof. move=> aB bB h; split; [ fprops | by apply: cdiff_pr]. Qed.

Lemma cdiff_pr1 a b: inc a Bnat-> inc b Bnat ->
  (a +c b ) -c b = a.
Proof.
move=> aB bB.
move: (BS_sum aB bB)=> sB.
move: (Bsum_M0le bB aB); rewrite csumC=> aux.
move: (cdiff_pr aux); rewrite csumC=> aux'.
apply: (csum_simplifiable_right bB (BS_diff _ sB) aB aux').
Qed.

Lemma cdiff_rpr a b:
  b <=c a -> (a -c b ) +c b = a.
Proof. by move=> leaB;rewrite csumC; apply: cdiff_pr. Qed.

Lemma cdiff_pr2 a b c: inc a Bnat-> inc b Bnat ->
  a +c b = c -> c -c b = a.
Proof. by move=> aB bB h; move: (cdiff_pr1 aB bB); rewrite h. Qed.

Lemma cdiff_pr3 a b n:
   inc n Bnat -> a <=c b -> b <=c n -> (n -c b ) <=c (n -c a ).
Proof.
move => mB le1 le2.
have bB:=(BS_le_int le2 mB).
have aB:=(BS_le_int le1 bB).
have dB:=(BS_sum (BS_diff a bB) (BS_diff b mB)).
rewrite - {2} (cdiff_pr le2).
rewrite -{2} (cdiff_pr le1) - csumA (csumC a) (cdiff_pr1 dB aB) csumC.
apply:(csum_M0le _ (CS_diff n b)).
Qed.

Lemma cdiff_pr7 a b c:
  a <=c b -> b <c c -> inc c Bnat -> (b -c a ) <c (c -c a ).
Proof.
move => le1 lt2 cB.
have bB:= (BS_lt_int lt2 cB).
have aB:= (BS_le_int le1 bB).
move:(BS_diff a bB) (BS_diff b cB) => ha hb.
rewrite -(cdiff_pr (proj1 lt2)) - {2}(cdiff_pr le1) - csumA csumC.
rewrite (cdiff_pr1 (BS_sum ha hb) aB);apply: (csum_M0lt ha hb).
split; [ apply: czero_least;fprops | apply: (nesym (cdiff_nz lt2))].
Qed.

Lemma cardinal_setC4 E A: sub A E ->
  finite_set E -> cardinal (E -s A) = (cardinal E ) -c (cardinal A ).
Proof.
move => AE fe.
move: (cardinal_setC AE) =>cc.
have ccEA: cardinalp (cardinal (E -s A)) by fprops.
have ccA: cardinalp (cardinal A) by fprops.
symmetry; rewrite - cc csumC.
move: fe => /BnatP; rewrite - cc => sB.
apply: cdiff_pr1 =>//.
   apply: (Bnat_in_sum ccEA sB).
rewrite csumC in sB;apply: (Bnat_in_sum ccA sB).
Qed.

Lemma cdiff_n_n a: a -c a = \0 c.
Proof. by rewrite /card_diff setC_v cardinal_set0. Qed.

Lemma cdiff_n_0 a: inc a Bnat -> a -c \0 c = a.
Proof. move=> aB; apply: cdiff_pr2; fprops; aw; fprops. Qed.

Lemma cdiff_pr4 a b a' b': inc a Bnat-> inc b Bnat ->
  inc a' Bnat-> inc b' Bnat ->
  a <=c b -> a' <=c b' ->
  (b +c b') -c (a +c a') = (b -c a ) +c (b' -c a').
Proof.
move=> aB bB a'B b'B ab a'b'.
apply: cdiff_pr2; [ fprops | fprops |].
have aux: ((b -c a) +c b') +c a = b' +c b.
  by rewrite (csumC _ b') - csumA cdiff_rpr.
by rewrite (csumC a a') csumA - (csumA _ _ a') (cdiff_rpr a'b') aux csumC.
Qed.

Lemma cdiffA a b c:
  inc a Bnat -> inc b Bnat -> inc c Bnat ->
  (b +c c ) <=c a -> (a -c b ) -c c = a -c (b +c c ).
Proof.
move=> aB bB cB h.
move: (cdiff_pr h) => aux.
apply: cdiff_pr2 =>//; first by fprops.
symmetry; apply: cdiff_pr2; fprops.
by rewrite - csumA csumC (csumC c b).
Qed.

Lemma cpred_pr4 a: cardinalp a -> cpred a = a -c \1 c.
Proof.
move=> ca.
case: (finite_dichot ca).
  case/finite_succ => anz.
    rewrite /cpred /card_diff anz setU_0 setC_T ?cardinal_set0; fprops.
  move: anz => [y fy sy].
  rewrite sy - {2} (succ_of_finite fy) (card_succ_pr4 (CS_finite_o fy)).
  by rewrite /cpred (succo_K (proj1 fy)) (cdiff_pr1 _ BS1) //; apply /BnatP.
rewrite /cpred /card_diff.
move => pa; move: (proj1 (proj1 pa)) => oa.
move: (infinite_card_limit2 pa)=> pb.
move /(limit_ordinal_P1 oa): pb => [ane <-].
move: (ord_ne_pos oa ane) => /(ord_ltP oa) a0.
move: (ordinal_irreflexive oa) => ia.
rewrite -[a -s \1 c] /(a -s1 \0 o) -{1} (card_card ca); apply /card_eqP.
have: a +s1 a \Eq ((a -s1 \0 o ) +s1 \0 o ).
  rewrite (setC1_K a0); eqsym;move: pa => [] //.
by move /(setU1_injective_card2 ia (@setC1_1 \0 o a)).
Qed.

Lemma cdiff_nz1 a b: inc a Bnat -> inc b Bnat ->
  (succ b ) <=c a -> a -c b <> \0 c.
Proof.
move=> aB bB lesba; apply: cdiff_nz => //; apply /card_le_succ_ltP => //.
Qed.

Lemma cdiff_A1 a b: inc a Bnat -> inc b Bnat ->
  (succ b ) <=c a -> cpred (a -c b) = a -c (succ b ).
Proof.
move=> aB bB; rewrite (Bsucc_rw bB) => h'.
rewrite - cdiffA; fprops; apply: cpred_pr4; fprops.
Qed.

Lemma cdiff_le_symmetry a b:
  b <=c a -> (a -c b ) <=c a.
Proof.
move=> ba; move:(cdiff_pr ba) => aux.
rewrite -{2} aux csumC; apply: csum_M0le; apply:CS_diff.
Qed.

Lemma cdiff_lt_symmetry n p: inc p Bnat ->
  n <c p -> (cpred (p -c n)) <c p.
Proof.
move=> pB ltnp.
have snz := (cdiff_nz ltnp).
move: ltnp => [lenp _].
move: (cdiff_pr0 pB (BS_le_int lenp pB) lenp) => [sf aux].
move: (cpred_pr sf snz)=> [aa bb].
apply /(card_le_succ_ltP _ aa); rewrite - bb; apply: (cdiff_le_symmetry lenp).
Qed.

Lemma double_diff n p: inc n Bnat ->
  p <=c n -> n -c (n -c p ) = p.
Proof.
move=> nB lepn.
move: (BS_le_int lepn nB) => pB.
apply: cdiff_pr2; [exact pB | fprops | apply: cdiff_pr=>//].
Qed.

Lemma csucc_diff a b: inc a Bnat -> inc b Bnat ->
  (succ b ) <=c a -> a -c b = succ (a -c (succ b )).
Proof.
move=> aB bB aux; move: (BS_succ bB) => sB.
apply: cdiff_pr2 ; fprops.
have sb: inc (a -c (succ b)) Bnat by fprops.
rewrite (Bsucc_rw sb) - csumA.
have->: (\1 c +c b = succ b) by rewrite (Bsucc_rw bB) csumC.
apply: cdiff_rpr =>//.
Qed.

Lemma cardinal_complement_image1 f: injection f ->
  (cardinal ((target f ) -s (image_of_fun f ))) +c (cardinal (source f))
  = cardinal (target f).
Proof.
move => injf.
set A:= (image_of_fun f).
have ->: (cardinal (source f) = cardinal A).
  apply /card_eqP;exists (restriction_to_image f).
  rewrite /restriction_to_image/restriction2; red;aw; split => //.
  by apply: (restriction_to_image_fb injf).
symmetry; rewrite csumC.
set B:= (target f) -s A.
have p0: sub A (target f) by apply: fun_image_Starget; fct_tac.
have <-: A \cup B = target f by apply: setU2_Cr.
rewrite csum2_pr2a csum2_pr2b csum2_pr5 //;apply: set_I2Cr.
Qed.

Lemma cardinal_complement_image f: injection f ->
  finite_set (target f) ->
    cardinal ((target f ) -s (image_of_fun f )) =
    (cardinal (target f)) -c (cardinal (source f)).
Proof.
move=> injf fst.
move: (cardinal_complement_image1 injf).
move: fst => /BnatP fb h.
rewrite - h in fb |- *.
have aB := (Bnat_in_sum (CS_cardinal (source f)) fb).
have cB:= (Bnat_in_sum2 (CS_cardinal (target f -s image_of_fun f)) fb).
by symmetry;apply: cdiff_pr1.
Qed.

Lemma Bnat_le_R a: inc a Bnat -> a <=N a.
Proof. move => aB; split;fprops. Qed.

Lemma Bnat_le_T a b c: a <=N b -> b <=N c -> a <=N c.
Proof.
move /Bnat_order_leP => ab /Bnat_order_leP bc; apply /Bnat_order_leP.
move: Bnat_order_wor=> [[or wor] _]; order_tac.
Qed.

Lemma Bnat_le_A a b: a <=N b -> b <=N a -> a = b.
Proof.
move /Bnat_order_leP => ab /Bnat_order_leP ba.
move: Bnat_order_wor=> [[or wor] _]; order_tac.
Qed.

Lemma Bnato_to_el a b: inc a Bnat -> inc b Bnat ->
  a <=N b \/ b <N a.
Proof.
move=> aB bB.
move:Bnat_order_wor=> [wor sr].
move: (worder_total wor)=> [or prop].
case: (equal_or_not b a).
  move=>->; left; apply /Bnat_order_leP.
  order_tac; by rewrite sr.
rewrite sr in prop; case: (prop _ _ aB bB); move /Bnat_order_leP.
  by left.
by move => pa pb; right; split.
Qed.

Lemma csum_le_simplifiable a b c:
  inc a Bnat -> inc b Bnat -> inc c Bnat->
  (a +c b ) <=c (a +c c ) -> b <=c c.
Proof.
move=> aB bB cB abc.
case: (Bnat_to_el bB cB) => // ltcb.
move: (csum_Mlelt aB bB (card_leR (CS_Bnat aB)) ltcb)=> h; co_tac.
Qed.

Lemma csum_lt_simplifiable a b c:
  inc a Bnat -> inc b Bnat -> inc c Bnat->
  (a +c b ) <c (a +c c ) -> b <c c.
Proof.
move=> aB bB cB [abc nac]; split.
  apply: (csum_le_simplifiable aB bB cB abc).
by dneg bc; rewrite bc.
Qed.

Lemma cprod_le_simplifiable a b c:
  inc a Bnat -> inc b Bnat -> inc c Bnat-> a <> \0 c ->
  (a *c b ) <=c (a *c c ) -> b <=c c.
Proof.
move=>aB bB cB naz abc.
case: (Bnat_to_el bB cB) => // ltcb.
move: (cprod_Mlelt aB bB (card_leR (CS_Bnat aB)) ltcb naz)=> h; co_tac.
Qed.

Lemma cprod_lt_simplifiable a b c:
  inc a Bnat -> inc b Bnat -> inc c Bnat-> a <> \0 c ->
  (a *c b ) <c (a *c c ) -> b <c c.
Proof.
move=> aB bB cB naz [abc nac]; split.
   by apply: (cprod_le_simplifiable aB).
by dneg bc; rewrite bc.
Qed.

Lemma cdiff_pr5 a b c: inc a Bnat -> inc b Bnat -> inc c Bnat ->
  (a +c c ) -c (b +c c ) = a -c b.
Proof.
move => aB bB cB.
case: (Bnat_to_ee aB bB) => ab.
  symmetry; rewrite (cdiff_wrong ab) (cdiff_wrong) //.
  by apply:csum_Mleeq.
by apply:cdiff_pr2; fprops; rewrite csumA (csumC _ b) cdiff_pr.
Qed.

Lemma cdiff_pr6 a b: inc a Bnat -> inc b Bnat ->
  (succ a ) -c (succ b ) = a -c b.
Proof.
move=> aB bB; rewrite !Bsucc_rw //;apply: cdiff_pr5 =>//; fprops.
Qed.

Lemma cdiff_increasing2 a b c: inc a Bnat -> inc b Bnat ->
  c <=c (a +c b ) -> (c -c b ) <=c a.
Proof.
move=> aB bB cab.
move: (BS_le_int cab (BS_sum aB bB)) => cB.
case: (Bnat_to_ee cB bB) => cb; first by rewrite cdiff_wrong; fprops.
apply: (csum_le_simplifiable (a:= b)); fprops.
rewrite csumC in cab; rewrite cdiff_pr //.
Qed.

Lemma cdiff_increasing3 a b c: inc a Bnat ->inc c Bnat ->
  b <=c c -> c <c (a +c b ) -> (c -c b ) <c a.
Proof.
move=> aB cB bc cab.
move: (BS_le_int bc cB) => bB.
apply: (csum_lt_simplifiable (a:= b)); fprops.
rewrite csumC in cab; rewrite cdiff_pr //.
Qed.

EIII-5-3 Intervals in sets of integers

Definition Bintcc a b := interval_cc Bnat_order a b.
Definition Bint a:= interval_co Bnat_order \0 c a.
Definition Bintc a:= Bintcc \0 c a.
Definition Bint1c a:= Bintcc \1 c a.

Definition Bint_cco a b :=
  graph_on cardinal_le (interval_cc Bnat_order a b).

Lemma Bintc_i b x: inc x (Bintc b) -> x <=c b.
Proof. by move /Bint_ccP => [_ [_ _ h]]. Qed.

Lemma BintcP b: inc b Bnat -> forall x, (inc x (Bintc b) <-> x <=c b).
Proof.
move=> bB x; split; first by apply: Bintc_i.
move => h;apply /(Bint_ccP1 BS0 bB); split => //; apply: czero_least; co_tac.
Qed.

Lemma Bint1cP b: inc b Bnat -> forall x,
  (inc x (Bint1c b) <-> (x <> \0 c /\ x <=c b )).
Proof.
move=> bB x; apply: (iff_trans (Bint_ccP1 BS1 bB x)).
split.
  move => [pa pb];split => //.
  move=> bz; rewrite bz in pa.
  move: (card_le0 pa); apply: card1_nz.
move => [x0 xb]; split => //.
by move: xb => [cb _ _]; apply: card_ge1.
Qed.

Lemma Bint1cPb b: inc b Bnat -> forall x,
  (inc x (Bint1c b) <-> (\1 c <=c x /\ x <=c b )).
Proof. move=> aB x; apply: (Bint_ccP1 BS1 aB). Qed.

Lemma Bint_S a b: sub (Bintcc a b) Bnat.
Proof. rewrite /Bintcc /interval_cc (proj2 Bnat_order_wor); apply: Zo_S. Qed.

Lemma Bint_S1 a: sub (Bint a) Bnat.
Proof. rewrite /Bint /interval_co (proj2 Bnat_order_wor); apply: Zo_S. Qed.

Lemma Bint_i a x: inc x (Bint a) -> x <c a.
Proof. by move => /Bint_coP [_ [[_ _ ha] hb]]; split. Qed.

Lemma BintP a: inc a Bnat -> forall x,
  (inc x (Bint a) <-> x <c a).
Proof.
move=> aB x; split; first by apply:Bint_i.
move => xa; apply/(Bint_coP1 BS0 aB); split => //.
apply: czero_least; co_tac.
Qed.

Lemma BintsP a: inc a Bnat -> forall x,
  (inc x (Bint (succ a)) <-> x <=c a).
Proof.
move=> aB x; apply: (iff_trans (Bint_coP1 BS0 (BS_succ aB) x)); split.
  by move => [_ [pa pb]]; apply /(card_lt_succ_leP aB); split.
move => lxa;split; first by apply: czero_least; co_tac.
by apply /(card_lt_succ_leP aB).
Qed.

Lemma Bint_co_cc p: inc p Bnat -> Bintc p = Bint (succ p).
Proof.
move => pB; set_extens x.
  by move/(BintcP pB) /(BintsP pB).
by move /(BintsP pB)/(BintcP pB).
Qed.

Lemma Bint_co00: Bint \0 c = emptyset.
Proof. apply /set0_P=> t; move /(BintP BS0); apply: card_lt0. Qed.

Lemma Bint_co01: (inc \0 o (Bint \1 c) /\ Bint \1 c = singleton \0 c).
Proof.
have zi: inc \0 c (Bint \1 c).
   apply/(BintP BS1); apply: card_lt_01.
split => //.
apply: set1_pr => // z /(BintP BS1).
rewrite - succ_zero; move/(card_lt_succ_leP BS0);apply: card_le0.
Qed.

Lemma Bint_cc00: Bintc \0 c = singleton \0 c.
Proof.
by rewrite -(proj2 Bint_co01) - succ_zero (Bint_co_cc BS0).
Qed.

Lemma Bintc_M a b: inc b Bnat ->
  a <=c b -> sub (Bintc a) (Bintc b).
Proof. move=> bB ab t /(Bintc_i) ta; apply /(BintcP bB); co_tac. Qed.

Lemma Bintc_M1 a: inc a Bnat ->
  sub (Bintc a) (Bintc (succ a)).
Proof. move=> aB;apply: Bintc_M; fprops. Qed.

Lemma Bint_si a: inc a Bnat ->
  inc a (Bint (succ a)).
Proof. move=> aB; apply /(BintsP aB); fprops. Qed.

Lemma Bint_M a: inc a Bnat -> sub (Bint a) (Bint (succ a)).
Proof.
move=> aB t /(BintP aB) tx; apply/(BintsP aB); co_tac.
Qed.

Lemma Bint_M1 a b: inc b Bnat -> a <=c b -> sub (Bint a) (Bint b).
Proof.
move=> bB ab r /Bint_i ra; apply /(BintP bB); co_tac.
Qed.

Lemma Bint_pr4 n: inc n Bnat ->
  ( ((Bint n ) +s1 n = (Bint (succ n)))
    /\ ~(inc n (Bint n))).
Proof.
move=> nB.
split; last by move/(BintP nB) => [_].
set_extens t.
   case/setU1_P.
    by apply:Bint_M.
    by move => ->; apply:Bint_si.
move /(BintsP nB) => tn; apply/setU1_P.
case: (equal_or_not t n); first by right.
by move => ntn; left; apply/(BintP nB); split.
Qed.

Lemma Bint_pr5 n (si := Bintcc \1 c n): inc n Bnat ->
  ( (si +s1 \0 c = Bintc n ) /\ ~(inc \0 c si )).
Proof.
move=> nB; split.
  set_extens x.
    case /setU1_P; first by move /(Bint_ccP1 BS1 nB) => [_]/(BintcP nB).
    move => ->; apply /(BintcP nB); fprops.
  move /(BintcP nB) => h; apply /setU1_P.
  case: (equal_or_not x \0 c) => xz; [right => //| left => // ].
  apply /(Bint_ccP1 BS1 nB);split => //;apply: card_ge1 => //;co_tac.
move /(Bint_ccP1 BS1 nB) => [h _].
move: card_lt_01 => xx; co_tac.
Qed.

Lemma incsx_intsn x n:
  inc n Bnat ->
  inc x (Bint n) -> inc (succ x) (Bint (succ n)).
Proof.
move => nB.
move/(BintP nB) => lin.
apply /(BintsP nB); apply /card_le_succ_lt0P => //; co_tac.
Qed.

Lemma inc0_int01: inc \0 c (Bint \1 c).
Proof. by apply /(BintP); fprops; apply: card_lt_01. Qed.

Lemma inc0_int02: inc \0 c (Bint \2 c).
Proof. by apply /(BintP); fprops; apply: card_lt_02. Qed.

Lemma cardinal_c_induction5 (r:property) a:
  inc a Bnat -> r \0 c ->
  (forall n, n <c a -> r n -> r (succ n))
  -> (forall n, n <=c a -> r n).
Proof.
move=> aB r0 rs.
have rss: forall n,
  inc n (Bint a) -> r n -> r (succ n).
  by move=> n /(BintP aB); apply: rs.
move: (cardinal_c_induction3_v (r:=r) BS0 aB r0 rss) => h n na.
by apply: h; apply /(BintcP aB).
Qed.

Section IntervalBnatwo.
Variables (a b: Set).
Hypotheses (aB:inc a Bnat)(bB:inc b Bnat).

Lemma Binto_wor: worder_on (Bint_cco a b) (Bintcc a b).
Proof.
move: cardinal_le_wor => wo.
have r: (forall x, inc x (interval_cc Bnat_order a b) -> x <=c x).
  move=> x xb; exact (card_leR (CS_Bnat (Bint_S xb))).
by move: (wordering_pr wo r).
Qed.

Lemma Binto_gleP x y:
  gle (Bint_cco a b) x y <->
    [/\ inc x (Bintcc a b), inc y (Bintcc a b) & x <=c y].
Proof. apply: graph_on_P1. Qed.

Lemma Binto_gleP2 x y:
  gle (Bint_cco a b) x y <-> [/\ a <=c x, y <=c b & x <=c y].
Proof.
split.
  move/Binto_gleP=> [] /(Bint_ccP1 aB bB) [pa pb] /(Bint_ccP1 aB bB) [pc pd] pe.
  done.
move => [pa pb pc]; apply/Binto_gleP; split => //;
  apply /(Bint_ccP1 aB bB); split => //; co_tac.
Qed.

End IntervalBnatwo.

Definition Bint_co a :=
  graph_on cardinal_le (Bint a).

Section IntervalBnatwo1.
Variable (a: Set).
Hypothesis (aB:inc a Bnat).

Lemma Bintco_wor: worder_on (Bint_co a) (Bint a).
Proof.
move: cardinal_le_wor => wo.
have r: forall x, inc x (Bint a) -> x <=c x.
  move=> x xi; move: (Bint_S1 xi) => xB; fprops.
by move: (wordering_pr wo r).
Qed.

Lemma Bintco_gleP x y: (gle (Bint_co a) x y <-> (x <=c y /\ y <c a )).
Proof.
split.
  by move /graph_on_P1 => [] /(BintP aB) xa /(BintP aB) ya xy.
move=> [xy ya]; apply/graph_on_P1; split => //;
  apply /(BintP aB) => //; co_tac.
Qed.

End IntervalBnatwo1.

Lemma segment_Bnat_order x: inc x Bnat ->
  segment Bnat_order x = interval_co Bnat_order \0 c x.
Proof.
move=> xB; set_extens t; move /Zo_P => [pa pb];apply:Zo_i => //.
  move: pb => [] /Bnat_order_leP [tn aa bb] cc.
  split; first by apply/Bnat_order_leP; split; fprops.
  split; first by apply/Bnat_order_leP; split; fprops.
  exact.
by case: pb.
Qed.

Definition rest_plus_interval a b :=
  Lf(fun z => z +c b)(Bintcc \0 c a) (Bintcc b (a +c b)).

Definition rest_minus_interval a b :=
  Lf(fun z => z -c b) (Bintcc b (a +c b)) (Bintcc \0 c a).

Theorem restr_plus_interval_is a b: inc a Bnat -> inc b Bnat->
[/\ bijection (rest_plus_interval a b) ,
   bijection (rest_minus_interval a b),
   (rest_minus_interval a b ) = inverse_fun (rest_plus_interval a b) &
   order_isomorphism (rest_plus_interval a b)
  (Bint_cco \0 c a)
  (Bint_cco b (a +c b))].
Proof.
move=> aB bB.
move: BS0 => zB.
move: (BS_sum aB bB) => abB.
set E1:= Bintc a.
set E2:= Bintcc b (a +c b).
have tap: lf_axiom (fun z => z +c b) E1 E2.
  move => z /(BintcP aB) za; apply/(Bint_ccP1 bB abB); split.
    rewrite csumC; apply: csum_M0le; fprops.
  apply: csum_Mlele=>//; fprops.
have tam: lf_axiom (fun z => z -c b) E2 E1.
  move => z /(Bint_ccP1 bB abB) [bt tab]; apply /(BintcP aB).
  move: (BS_diff b (BS_le_int tab abB)) => sB; apply: cdiff_increasing2 =>//.
set (f:= rest_plus_interval a b).
set (g:= rest_minus_interval a b).
have ff:function f by apply: lf_function.
have fg:function g by apply: lf_function.
have sf:source f = target g by rewrite lf_source lf_target.
have sg:source g = target f by rewrite lf_source lf_target.
have cfg:f \coP g by [].
have cgf: g \coP f by [].
have c1: g \co f = identity (source f).
  apply: function_exten; [fct_tac | fprops | aw | symmetry; aw | ].
  rewrite compf_s;move=> x xsf /=.
  rewrite (identity_V xsf); aw.
  move: xsf; rewrite lf_source=> xs.
  rewrite (lf_V tap xs) (lf_V tam (tap _ xs)).
  rewrite cdiff_pr1 =>//; apply: (Bint_S xs).
have c2: f \co g = identity (source g).
  apply: function_exten ; [fct_tac | fprops | aw | symmetry; aw | ].
  rewrite compf_s;move=> x xsg /=.
  rewrite (identity_V xsg) (compf_V cfg xsg).
  move: xsg; rewrite lf_source=> xs.
  rewrite (lf_V tam xs).
  have xB: inc x Bnat by apply :(Bint_S xs).
  move: xs => /(Bint_ccP1 bB abB) [bx xaB].
  have aux: inc (x -c b) (Bintcc \0 c a).
    apply/(BintcP aB); apply: cdiff_increasing2 =>//.
  rewrite (lf_V tap aux) csumC cdiff_pr //.
move: (bijective_from_compose cgf cfg c1 c2)=> [bf bg gif]; split => //.
have sp : E1 = source (rest_plus_interval a b).
  by rewrite /rest_plus_interval; aw.
move: (Binto_wor \0 c a) => [[o1 _ ] sr1].
move: (Binto_wor b (a +c b))=> [[o2 _ ] sr2].
red;rewrite /bijection_prop sr1 sr2 lf_source lf_target;split => //.
move=> x y /=; rewrite lf_source => xsf ysf.
rewrite (lf_V tap xsf) (lf_V tap ysf).
apply: (iff_trans (Binto_gleP \0 c a x y)).
symmetry.
apply (iff_trans (Binto_gleP b (a +c b) (x +c b) (y +c b))).
split; move => [pa [pb pc]];split => //; try (apply: tap => //).
  apply: (csum_le_simplifiable bB (Bint_S xsf) (Bint_S ysf)).
  by rewrite csumC (csumC b y).
apply: csum_Mlele=>//; fprops.
Qed.

Lemma card_Bintc a: inc a Bnat ->
  cardinal (Bintc a) = succ a.
Proof.
move: a; apply: cardinal_c_induction.
  rewrite succ_zero Bint_cc00; apply: cardinal_set1.
move => n nB.
move: (BS_succ nB) => snB.
rewrite (Bint_co_cc nB) (Bint_co_cc snB).
have [<- aux]:= (Bint_pr4 snB).
by rewrite card_succ_pr ; [move => -> |].
Qed.

Lemma Bint_pr1 a: inc a Bnat -> a <> \0 c ->
  Bintcc \0 c (cpred a) = Bint a.
Proof.
move: BS0 => zB.
move=> aB naz;move: (cpred_pr aB naz) => [fp ass].
rewrite {2} ass - Bint_co_cc //.
Qed.

Lemma card_Bintcp a: inc a Bnat -> a <> \0 c ->
  cardinal (Bintc (cpred a)) = a.
Proof.
move=> aB naz.
by move: (cpred_pr aB naz) => [fp ass]; rewrite card_Bintc.
Qed.

Lemma card_Bint a: inc a Bnat ->
  cardinal (Bint a) = a.
Proof.
move=> aB; case: (equal_or_not a \0 c).
  move => ->; rewrite Bint_co00; apply: cardinal_set0.
move=> h; rewrite - Bint_pr1//; apply: card_Bintcp=>//.
Qed.

Theorem card_Bintcc a b: a <=N b ->
  cardinal (Bintcc a b) = succ (b -c a).
Proof.
move=> [aB bB ab].
move: (cdiff_pr ab) (BS_diff a bB) => aux cB.
rewrite csumC in aux.
set (c:= b -c a) in *.
move: (restr_plus_interval_is cB aB) => [b1 _ _ _].
have eq: (Bintcc \0 c c) \Eq (Bintcc a b).
  exists (rest_plus_interval c a); rewrite /rest_plus_interval.
  red;rewrite lf_source lf_target; split => //; ue.
by rewrite -(card_Bintc cB); apply /card_eqP; eqsym.
Qed.

Lemma card_Bint1c a: inc a Bnat ->
  cardinal (Bint1c a) = a.
Proof.
move => aB.
case: (equal_or_not a \0 c).
  move=> ->.
  have ->: (Bint1c \0 c = emptyset).
    rewrite /Bint1c.
    apply /set0_P => y; move /(Bint1cPb BS0)=> [c1y cy0].
    move: (card_leT c1y cy0) card_lt_01 => h1 h2;co_tac.
  apply: cardinal_set0.
move => anz.
have aux1: \1 c <=c a by apply: card_ge1; fprops.
have aux: \1 c <=N a by split;fprops.
have so: inc (a -c \1 c) Bnat by move: BS1 => i1; fprops.
rewrite card_Bintcc // Bsucc_rw // csumC.
apply: cdiff_pr; fprops.
Qed.

Lemma finite_Bintcc a b: finite_set (Bintcc a b).
Proof.
apply/card_finite_setP.
case: (p_or_not_p (a <=N b)) => h.
  rewrite card_Bintcc //; move: h => [aB bB _]; fprops.
have ->: (Bintcc a b) = emptyset.
   apply /set0_P => t /Zo_hi [] /Bnat_order_leP [pa _ pc]
      /Bnat_order_leP [_ pe pf].
   case: h; split;fprops; co_tac.
rewrite cardinal_set0; fprops.
Qed.

Lemma finite_Bint a: finite_set (Bint a).
Proof.
have aux:sub (Bint a) (Bintcc \0 c a).
   by move => t /Zo_P [pa [pb [pc _]]]; apply /Zo_P.
have : (finite_set (Bintcc \0 c a)) by apply: finite_Bintcc.
apply: (sub_finite_set aux).
Qed.

Lemma infinite_Bnat_alt: ~(finite_set Bnat ).
Proof.
move /BnatP =>h.
move: (sub_smaller (Bint_S (a:=\0 c) (b:=cardinal Bnat))).
rewrite (card_Bintc h).
by move /(card_le_succ_ltP _ h) => [_].
Qed.

Lemma isomorphism_worder_finite r r':
  total_order r -> total_order r' ->
  finite_set (substrate r) -> (substrate r ) \Eq (substrate r') ->
  exists ! f, order_isomorphism f r r'.
Proof.
move=> tor tor' fs.
move /card_eqP => sc.
have fs': finite_set (substrate r') by red; rewrite - sc.
move:(finite_set_torder_wor tor fs) (finite_set_torder_wor tor' fs').
move => wor wor'; move: (isomorphism_worder wor wor') => iw.
have aux: forall u v f, order_isomorphism f u v ->
   segmentp v (range (graph f)) /\ order_morphism f u v.
  move => f u v h; split; last by apply:order_isomorphism_w.
  move: h => [_ or' [[injf sjf] sf tf] pf].
  by rewrite (surjective_pr3 sjf) tf; apply: substrate_segment.
case: iw.
  move => [f [[pa mf] pc]]; exists f; split.
    move: (order_morphism_fi mf) => injf.
    move: mf => [o1 o2 [ff sf tf] pf]; split => //; split => //.
    apply: bijective_if_same_finite_c_inj; [ by rewrite sf tf | ue| exact].
by move => f' xx; apply:pc; apply: aux.
move => [f [[pa mf] pc]].
have oi: (order_isomorphism f r' r).
  move: (order_morphism_fi mf) => injf.
  move: mf => [o1 o2 [ff sf tf] pf].
   have bf: bijection f by apply: bijective_if_same_finite_c_inj;
     rewrite ? sf ?tf;[ symmetry; apply: sc| exact| exact].
   split=> //.
move: (inverse_order_is oi)=> oii.
exists (inverse_fun f); split => //.
move => f' h1.
rewrite (pc _ (aux _ _ _ (inverse_order_is h1))).
move: h1 => [_ _ [[[ff _] _] _ _] _ ].
by rewrite (ifun_involutive ff).
Qed.

Theorem finite_ordered_interval r: total_order r ->
  finite_set (substrate r) ->
  exists ! f, order_isomorphism f r
    (Bint_cco \1 c (cardinal (substrate r))).
Proof.
move=> tot fs.
move: (fs); move/BnatP => fs'.
move: (Binto_wor \1 c (cardinal (substrate r))) => [pa pb].
move: (card_Bint1c fs').
move/card_eqP;rewrite /Bint1c - pb; fprops.
move => h;apply: (isomorphism_worder_finite tot (worder_total pa) fs).
by eqsym.
Qed.

Theorem finite_ordered_interval1 r: total_order r ->
  finite_set (substrate r) ->
  exists !f, order_isomorphism f r
    (Bint_co (cardinal (substrate r))).
Proof.
move=> tor fs.
move: (finite_set_torder_wor tor fs)=> wor.
move: (fs) => /BnatP fs'.
move: (card_Bint fs') => /card_eqP.
rewrite - (proj2 (Bintco_wor _)) // => e.
move: (worder_total (proj1(Bintco_wor (cardinal (substrate r))))) => tor'.
by apply: (isomorphism_worder_finite tor tor' fs); eqsym.
Qed.

A finite sum or product can be defined by induction

Lemma induction_on_sum a f: inc a Bnat ->
  let iter := fun n=> card_sumb (Bint n) f
    in (iter a ) +c (f a ) = (iter (succ a)).
Proof.
move=> aB /=.
by move: (Bint_pr4 aB) => [<- aux];symmetry; apply csumA_setU1.
Qed.

Lemma induction_on_prod a f: inc a Bnat ->
  let iter := fun n=> card_prodb (Bint n) f
    in (iter a ) *c (f a ) = (iter (succ a)).
Proof.
move=> aB /=.
move: (Bint_pr4 aB) => [<- aux].
by symmetry; apply cprodA_setU1.
Qed.

Lemma fct_sum_rec0 f n: inc n Bnat ->
  card_sumb (Bintc n) f = (card_sumb (Bint1c n) f ) +c (f \0 c ).
Proof.
move=> nB; move: (Bint_pr5 nB) => [<- aux].
by apply csumA_setU1.
Qed.

Lemma fct_sum_rec1 f n: inc n Bnat ->
  card_sumb (Bintcc \0 c (succ n)) f
  = (card_sumb (Bintcc \0 c n) (fun i=> f (succ i))) +c (f \0 c ).
Proof.
move=> nB.
have sB:inc (succ n) Bnat by fprops.
rewrite (fct_sum_rec0 _ sB); congr (_ +c (f \0 c )).
set i1:= Bint1c _ ; set i0:= Bintcc _ _.
have p1: forall x : Set, inc x i0 -> inc (succ x) i1.
  move => t /(BintcP nB) => tn; apply /(Bint1cP sB).
  have ct: cardinalp t by co_tac.
  split; [ apply: succ_nz | apply/ (card_le_succ_succP ct )]; fprops.
rewrite /card_sumb (csum_Cn2 (I:=i0) (f:= succ)).
   congr (card_sum _); apply: Lg_exten; move=> x xi0 /=; bw; apply: p1=>//.
split => //.
    by move=> x xi; bw; apply: p1.
move=> u v ui vi susv; apply: succ_injective1.
     move: (Bint_S ui); fprops.
   move: (Bint_S vi); fprops.
   done.
move=> y; bw; move/(Bint1cP sB) => [nyz le_s].
have fy:inc y Bnat by Bnat_tac.
move: (cpred_pr fy nyz)=> [pB ns].
exists (cpred y) => //.
apply/(BintcP nB); apply/card_le_succ_succP => //; fprops; ue.
Qed.

Lemma fct_sum_rev f n: inc n Bnat ->
  let I := (Bint (succ n)) in
  card_sumb I f = card_sumb I (fun i=> f (n -c i)).
Proof.
move=> nB I.
have snB: inc (succ n) Bnat by fprops.
set X := Lg I f.
pose g i := n -c i.
have p1: forall x, inc x I -> inc (n -c x) I.
  move=> x /(BintsP nB) => xn; apply /(BintsP nB).
  apply: cdiff_le_symmetry =>//.
rewrite /card_sumb.
have->:(Lg I (fun i : Set => f (n -c i)) = Lg I (fun z => Vg X (g z))).
  apply: Lg_exten; move=> x xI; rewrite /X /g; bw; apply: p1 =>//.
apply: csum_Cn2; split => //.
    rewrite /g/X; bw.
  move=> x y /(BintsP nB) xn /(BintsP nB) yn; rewrite /g => h.
  by rewrite - (double_diff nB xn) -(double_diff nB yn) h.
rewrite /g; bw => y /(BintsP nB) yn; rewrite -(double_diff nB yn).
exists (n -c y) => //; apply /(BintsP nB).
apply: cdiff_le_symmetry =>//; Bnat_tac.
Qed.

EIII-5-4 Finite sequences

EIII-5-5 Characteristic functions on sets

Lemma char_fun_V_aa A x: inc x A ->
  Vf (char_fun A A) x = \1 c.
Proof. by move => xa; rewrite char_fun_V_a. Qed.

Lemma char_fun_V_bb A x: inc x A ->
  Vf (char_fun emptyset A) x = \0 c.
Proof.
move => xa; rewrite char_fun_V_b; fprops.
by apply /setC_P; split => // /in_set0.
Qed.

Lemma char_fun_constant A B:
   sub A B -> (cstfp (char_fun A B) B) -> (A =B \/ A = emptyset).
Proof.
move=> AB p.
case: (emptyset_dichot A); [by right | move=> [u uA]; left ].
apply: extensionality=>// t tB.
ex_middle v.
have xc:inc t (B -s A) by apply /setC_P; split =>//.
case: card1_nz.
by rewrite - (char_fun_V_b AB xc)- (char_fun_V_a AB uA) (p _ _ (AB _ uA) tB).
Qed.

Lemma char_fun_setC A B x: sub A B -> inc x B ->
  Vf (char_fun (B -s A) B) x = \1 c -c (Vf (char_fun A B) x ).
Proof.
move=> AB xB.
have sc:sub (B -s A) B by apply: sub_setC.
case: (inc_or_not x A).
  move=> xA; rewrite char_fun_V_b //.
    rewrite char_fun_V_a //; symmetry; apply: cdiff_n_n; fprops.
  by rewrite setC_K.
move=> h.
have xc: inc x (B -s A) by apply/setC_P.
rewrite char_fun_V_a // char_fun_V_b //.
symmetry;apply: cdiff_n_0; fprops.
Qed.

Lemma char_fun_setI A A' B x: sub A B -> sub A' B -> inc x B ->
  Vf (char_fun (A \cap A') B) x
  = (Vf (char_fun A B) x ) *c (Vf (char_fun A' B) x ).
Proof.
move=> AB A'B xB.
have Ha:sub (A \cap A') B.
  by move=> t /setI2_P [tA _]; apply: AB.
case: (inc_or_not x A) => h.
  have cW:cardinalp (Vf (char_fun A' B) x) by apply: char_fun_V_cardinal.
  rewrite (char_fun_V_a AB h) cprod1l //.
  case: (inc_or_not x A') => xA.
    have aux:inc x (A \cap A') by apply: setI2_i.
    rewrite char_fun_V_a // char_fun_V_a //.
  have aux:inc x (B -s (A \cap A'))
    by apply /setC_P;split => //; move /setI2_P =>[_].
  rewrite char_fun_V_b // char_fun_V_b //.
  by apply /setC_P.
have aux: inc x (B -s (A \cap A'))
by apply /setC_P;split => //; move /setI2_P =>[].
have aux2:inc x (B -s A) by fprops.
by rewrite char_fun_V_b // char_fun_V_b // cprodC cprod0r.
Qed.

Lemma char_fun_setU A A' B x: sub A B -> sub A' B -> inc x B ->
  (Vf (char_fun (A \cap A') B) x )
  +c (Vf (char_fun (A \cup A') B) x )
  = (Vf (char_fun A B) x ) +c (Vf (char_fun A' B) x ).
Proof.
move=> AB A'B xB.
have Ha:sub (A \cap A') B by move=> t /setI2_P [ta _]; apply: AB.
have Hb:sub (A \cup A') B by move=> t /setU2_P; case; fprops.
case: (p_or_not_p (inc x A))=> xA.
  rewrite (char_fun_V_a AB xA).
  rewrite (char_fun_V_a Hb (setU2_1 A' xA)).
  case: (p_or_not_p (inc x A'))=> xA'.
    rewrite (char_fun_V_a A'B xA') char_fun_V_a //.
     by apply: setI2_i.
  rewrite csumC; apply: f_equal.
  by rewrite ! char_fun_V_b //; apply /setC_P; split => //; move /setI2_P => [].
have Hc: inc x (B -s A) by fprops.
have Hd:inc x (B -s (A \cap A')).
  by apply /setC_P; split => //; move /setI2_P => [].
rewrite (char_fun_V_b AB Hc) (char_fun_V_b Ha Hd).
case: (p_or_not_p (inc x A')) => aux.
  have xu: inc x (A \cup A') by apply: setU2_2.
  by rewrite (char_fun_V_a Hb xu) (char_fun_V_a A'B aux).
have xc:inc x (B -s (A \cup A')).
  by apply /setC_P; split => //;move /setU2_P => [].
have xba: inc x (B -s A') by fprops.
by rewrite (char_fun_V_b Hb xc) (char_fun_V_b A'B xba).
Qed.

EIII-5-6 Euclidean Division

Lemma least_int_prop (prop:property):
  (forall x, prop x -> inc x Bnat) -> (exists x, prop x) ->
  prop \0 c \/ (exists x, [/\ inc x Bnat, prop (succ x) & ~ prop x]).
Proof.
move=> pi [x xp].
set (X:=Zo Bnat prop).
have sX: sub X Bnat by apply: Zo_S.
have nX: nonempty X by exists x; apply: Zo_i=>//; apply: pi.
case: (Bnat_wordered sX nX)=> q.
   by left; move: q =>/Zo_P [_].
right; move: q=> [a [aB /Zo_hi psa /Zo_P h]]; ex_tac;fprops.
Qed.

Lemma least_int_prop1 (prop:property):
  (forall x, prop x -> inc x Bnat) -> ~(prop card_zero ) ->
  (exists x, prop x) -> (exists x, [/\ inc x Bnat, prop(succ x) & ~ prop x]).
Proof.
move=> alp npz exp; case: (least_int_prop alp exp)=>// h.
Qed.

Definition card_division_prop a b q r :=
  a = (b *c q ) +c r /\ r <c b.

Lemma card_division_prop_alt a b q r: inc a Bnat-> inc b Bnat ->
  inc q Bnat-> inc r Bnat -> b <> \0 c ->
  (card_division_prop a b q r <->
  [/\ (b *c q ) <=c a, a <c (b *c succ q ) & r = a -c (b *c q )]).
Proof.
move=> aB bB qB rB nzb; rewrite /card_division_prop.
set (w:= b *c q).
rewrite Bsucc_rw // cprodC cprod_sumDr cprodC cprod1l; fprops.
have wB: inc w Bnat by rewrite /w; fprops.
split.
  move=> [av lt];split => //.
  - rewrite av; apply: csum_M0le; fprops.
  - rewrite av; apply: csum_Mlelt; fprops.
  - by symmetry;apply: cdiff_pr2 =>//; symmetry; rewrite csumC.
move=> [lwa ltas rv].
rewrite rv.
have aux: inc (b *c q +c b) Bnat by fprops.
split; first by symmetry; apply: cdiff_pr =>//.
move: ltas => /(card_ltP aB aux) [c [cB nzc s]] {aux}.
move: (cdiff_pr lwa); rewrite -rv=> aux.
apply /(card_ltP rB bB); ex_tac.
apply: (@csum_simplifiable_left w);fprops.
by rewrite csumA aux.
Qed.

Lemma card_division_unique a b q r q' r': inc a Bnat-> inc b Bnat ->
  inc q Bnat-> inc r Bnat -> inc q' Bnat-> inc r' Bnat -> b <> \0 c ->
  card_division_prop a b q r -> card_division_prop a b q' r' ->
  (q = q' /\ r =r').
Proof.
move=> aB bB qB rB q'B r'B nbz.
move /(card_division_prop_alt aB bB qB rB nbz)=> [le1 lt1 e1].
move /(card_division_prop_alt aB bB q'B r'B nbz)=> [le2 lt2 e2].
suff : q = q' by move=> h; split => //; rewrite e1 e2 h.
move: (card_le_ltT le1 lt2) => lt3.
move: (card_le_ltT le2 lt1) => lt4.
move: (cprod_lt_simplifiable bB q'B (BS_succ qB) nbz lt4).
move: (cprod_lt_simplifiable bB qB (BS_succ q'B) nbz lt3).
move /(card_lt_succ_leP q'B) => pa /(card_lt_succ_leP qB) => pb; co_tac.
Qed.

Lemma card_division_exists a b: inc a Bnat-> inc b Bnat ->
  b <> \0 c -> exists q r,
    [/\ inc q Bnat, inc r Bnat & card_division_prop a b q r].
Proof.
move=> aB bB nzb.
set (pp:= fun q => inc q Bnat /\ a <c (b *c q )).
have np: (forall x, pp x -> inc x Bnat) by move => x [].
have zp: (~ (pp \0 c )).
   rewrite /pp; move => [_]; rewrite cprod0r.
   move=> h;apply: (card_lt0 h).
have ep: (exists x, pp x).
  rewrite /pp; exists (succ a); split; first by fprops.
  have aux: (succ a) <=c (b *c (succ a)).
     by rewrite cprodC; apply: Bprod_M1le; fprops.
  by apply /card_le_succ_ltP.
move: (least_int_prop1 np zp ep)=> [q [qB q1 q2]].
have p1: ((b *c q) <=c a).
  move: (Bnat_to_el (BS_prod bB qB) aB); case => //.
  move=> [p1 p2]; case: q2; split; [exact | split ] =>//.
move: (cdiff_pr p1); set (r:= a -c (b *c q)) => rp.
have rB: inc r Bnat by rewrite /r; apply: (BS_diff _ aB).
exists q; exists r; split => //; apply /card_division_prop_alt => //.
by split => //; move: q1=> [_].
Qed.

Definition card_quo a b := least_ordinal (fun q => a <c b *c (succ q )) a.
Definition card_rem a b := a -c (b *c (card_quo a b )).
Definition card_divides b a :=
  [/\ inc a Bnat, inc b Bnat & card_rem a b = \0 c].

Notation "x %/c y" := (card_quo x y) (at level 40).
Notation "x %%c y" := (card_rem x y) (at level 40).
Notation "x %|c y" := (card_divides x y) (at level 40).

Lemma cquo_zero a: a %/c \0 c = \0 c.
Proof.
rewrite /card_quo /least_ordinal.
set s := Zo _ _.
have -> : s = emptyset.
  apply /set0_P => y /Zo_hi; rewrite cprodC cprod0r; apply: card_lt0.
by rewrite setI_0.
Qed.

Lemma card_division a b (q := a %/c b) (r := (a %%c b)):
  inc a Bnat -> inc b Bnat -> b <> \0 c ->
  [/\ inc q Bnat, inc r Bnat & card_division_prop a b q r].
Proof.
move=> aB bB bnz.
pose p z := (a <c b *c succ z).
have ca: cardinalp a by fprops.
have oa: ordinalp a by apply:OS_cardinal.
have pa: p a.
have aux: (succ a) <=c (b *c (succ a)).
     by rewrite cprodC; apply: Bprod_M1le; fprops.
  by apply /card_le_succ_ltP.
move: (least_ordinal1 oa pa); rewrite /p -/q.
move=> [qa qb qc].
have qd: q <=o a by split => //; exact (qc _ oa pa).
have qB: inc q Bnat.
  case: (equal_or_not q a); first by move => ->.
  move=> naq.
  have: q <o a by split.
  move /ord_ltP0 => [_ _ qe].
  move /BnatP: aB => aB; apply /BnatP;exact: (finite_o_increasing qe aB).
have rB: inc r Bnat by apply: BS_diff => //; apply: BS_prod.
split => //.
apply /card_division_prop_alt => //; split => //.
case: (p_or_not_p (q = \0 c)).
  move=> ->; rewrite cprod0r; apply: czero_least; fprops.
move=> qnz; move: (cpred_pr qB qnz); set (z := (cpred q)).
move => [zB qs].
case: (card_le_to_el (CS_prod2 b q) ca) => //; rewrite qs => h.
have oz: ordinalp z by apply:OS_cardinal; fprops.
move: (qc _ oz h) => qz.
have zq : inc z q.
  have fz: finite_c z by fprops.
  rewrite qs (succ_of_finite fz) /succ_o; fprops.
case: (ordinal_irreflexive oz (qz _ zq)).
Qed.

Lemma crem_zero a: inc a Bnat -> a %%c \0 c = a.
Proof. move => h; rewrite /card_rem cprodC cprod0r cdiff_n_0 //. Qed.

Lemma BS_quo a b: inc a Bnat-> inc b Bnat ->
  inc (a %/c b) Bnat.
Proof.
move => aB bB.
case: (equal_or_not b \0 c) => bnz.
  rewrite bnz cquo_zero;fprops.
exact: (proj31 (card_division aB bB bnz)).
Qed.

Lemma BS_rem a b: inc a Bnat-> inc b Bnat ->
  inc (a %%c b) Bnat.
Proof.
move => aB bB.
case: (equal_or_not b \0 c) => bnz.
  rewrite bnz crem_zero //.
exact: (proj32 (card_division aB bB bnz)).
Qed.

Hint Resolve BS_rem BS_quo: fprops.

Lemma cdiv_pr a b: inc a Bnat-> inc b Bnat ->
  a = (b *c (a %/c b )) +c (a %%c b ).
Proof.
move => aB bB.
case: (equal_or_not b \0 c) => bnz.
  rewrite bnz (crem_zero aB) cquo_zero cprod0r; aw; fprops.
by move: (card_division aB bB bnz) =>[_ _ [h _]].
Qed.

Lemma crem_pr a b: inc a Bnat-> inc b Bnat -> b <> \0 c ->
  (a %%c b ) <c b.
Proof.
by move => aB bB bnz; move: (card_division aB bB bnz) =>[_ _ [_]].
Qed.

Lemma cquorem_pr a b q r:
  inc a Bnat-> inc b Bnat -> inc q Bnat -> inc r Bnat ->
  card_division_prop a b q r -> (q = a %/c b /\ r = a %%c b).
Proof.
move => aB bB qB rB p'.
case: (equal_or_not b \0 c) => bnz.
  move: p' => [_ ]; rewrite bnz =>h; case: (card_lt0 h).
move: (card_division aB bB bnz)=> [qqB rrB p].
apply: (card_division_unique aB bB qB rB qqB rrB bnz p' p).
Qed.

Lemma cquorem_pr0 a b q:
  inc a Bnat-> inc b Bnat -> inc q Bnat -> b <> \0 c ->
   a = (b *c q ) -> (q = a %/c b /\ \0 c = a %%c b).
Proof.
move => aB bB qB bnz p'.
apply: cquorem_pr =>//.
  fprops.
red; rewrite -p' (bsum0r aB).
split; [ trivial | split; [ apply: czero_least | ]]; fprops.
Qed.

Lemma cdivides_pr a b:
  b %|c a -> a = b *c (a %/c b ).
Proof.
move => [aB bB dv].
move: (cdiv_pr aB bB); rewrite dv.
by rewrite (bsum0r (BS_prod bB (BS_quo aB bB))).
Qed.

Lemma cdivides_pr1 a b: inc a Bnat -> inc b Bnat ->
  b %|c (b *c a ).
Proof.
move=> aB bB.
move: (BS_prod bB aB) => pB.
split => //.
case: (equal_or_not b card_zero) => bnz.
  rewrite bnz cprodC cprod0r crem_zero //; fprops.
by case: (cquorem_pr0 pB bB aB bnz (refl_equal (b *c a))).
Qed.

Lemma cdivides_pr2 a b q:
  inc a Bnat -> inc b Bnat -> inc q Bnat -> b <> \0 c ->
  a = b *c q -> q = a %/c b.
Proof.
move => aB bB qB nzb abq.
by case: (cquorem_pr0 aB bB qB nzb abq).
Qed.

Lemma cdivides_one a: inc a Bnat -> \1 c %|c a.
Proof.
move=> aB; rewrite - (cprod1l (CS_Bnat aB)).
apply: (cdivides_pr1 aB BS1).
Qed.

Lemma cquo_one a: inc a Bnat -> a %/c \1 c = a.
Proof.
move=> aB; symmetry; apply: cdivides_pr2; fprops; fprops.
rewrite cprod1l;fprops.
Qed.

Lemma cdivides_pr3 a b q:
   b %|c a -> q = a %/c b -> a = b *c q.
Proof. by move => H aux; move: (cdivides_pr H); rewrite -aux.
Qed.

Lemma cdivides_pr4 b q: inc b Bnat -> inc q Bnat -> b <> \0 c ->
   (b *c q ) %/c b = q.
Proof. move=> *; symmetry; apply: cdivides_pr2 =>//; fprops.
Qed.

Lemma cdivision_itself a: inc a Bnat -> a <> \0 c ->
  (a %|c a /\ a %/c a = \1 c).
Proof.
move=> aB anz; rewrite /card_divides.
have aux:a = a *c \1 c by rewrite (cprod1r (CS_Bnat aB)).
by move: (cquorem_pr0 aB aB BS1 anz aux) => [p1 p2].
Qed.

Lemma cdivides_itself a: inc a Bnat -> a <> \0 c ->
   a %|c a.
Proof. by move=> aB anz; move: (cdivision_itself aB anz) => [h _]. Qed.

Lemma cquo_itself a: inc a Bnat -> a <> \0 c ->
   a %/c a = \1 c.
Proof. by move=> aB anz; move: (cdivision_itself aB anz) => [ _ h]. Qed.

Lemma cdivision_of_zero a: inc a Bnat ->
  (a %|c \0 c /\ \0 c %/c a = \0 c).
Proof.
move=> aB; rewrite /card_divides.
move: BS0 => bs0.
have aux: \0 c = a *c \0 c by rewrite cprod0r.
case: (equal_or_not a \0 c) => anz.
  by rewrite anz cquo_zero crem_zero.
by move: (cquorem_pr0 BS0 aB BS0 anz aux) => [p1 p2].
Qed.

Lemma cdivides_trans a b a':
  a %|c a'-> b %|c a -> b %|c a'.
Proof.
move=> d1 d2.
rewrite (cdivides_pr d1) {1} (cdivides_pr d2) - cprodA.
move: d1 d2 => [p1 p2 _] [p3 p4 _].
apply: cdivides_pr1 =>//; fprops.
Qed.

Lemma cdivides_trans1 a b a':
  a %|c a' -> b %|c a
  -> a' %/c b = (a' %/c a ) *c (a %/c b ).
Proof.
move=> d1 d2.
move: (cdivides_pr d1).
rewrite {1} (cdivides_pr d2) - cprodA => h.
case: (equal_or_not b \0 c) => bnz.
by rewrite bnz cquo_zero cquo_zero cprod0r.
move: d1 d2 => [a'B aB _][_ bB _].
have pB: inc ((a %/c b) *c (a' %/c a)) Bnat by fprops.
rewrite - (cdivides_pr2 a'B bB pB bnz h).
by rewrite cprodC.
Qed.

Lemma cdivides_trans2 a b c: inc c Bnat ->
  b %|c a-> b %|c (a *c c ).
Proof.
move=> cB ba.
have aB: (inc a Bnat) by move: ba => [h _].
move: (cdivides_pr1 cB aB) => aux.
apply: (cdivides_trans aux ba).
Qed.

Lemma cquo_simplify a b c:
  inc a Bnat -> inc b Bnat -> inc c Bnat -> b <> \0 c -> c <> \0 c ->
  (a *c c ) %/c (b *c c ) = a %/c b.
Proof.
move=> aB bB cB bnz cnz.
move: (card_division aB bB bnz)=> [qB rB []].
set q:= (a %/c b); set r := a %%c b.
move=> e1 lrb; symmetry.
move: (BS_prod aB cB)(BS_prod bB cB)(BS_prod (BS_rem aB bB) cB) => p1 p2 p3.
have dv: (card_division_prop (a *c c) (b *c c) q (r *c c)).
  split.
     rewrite (cprodC b c) - cprodA (cprodC c _).
    by rewrite - cprod_sumDr e1.
  rewrite (cprodC b c) cprodC.
  apply: cprod_Mlelt =>//; fprops.
by move: (cquorem_pr p1 p2 qB p3 dv) => [res _].
Qed.

Lemma cdivides_and_sum a a' b: b %|c a -> b %|c a'
  -> (b %|c (a +c a') /\
    (a +c a') %/c b = (a %/c b ) +c (a' %/c b )).
Proof.
move=> d1 d2.
move: (cdivides_pr d1)(cdivides_pr d2)=> am bm.
set s := (a %/c b) +c (a' %/c b).
have ->: (a +c a' = b *c s).
  by rewrite /s cprod_sumDl -am -bm.
move: d1 d2 => [aB bB _][a'B _ _].
have sB:inc s Bnat by rewrite /s; fprops.
split; first by apply: cdivides_pr1 =>//.
case: (equal_or_not b \0 c) => bs.
  rewrite {2} /s bs ! cquo_zero; aw; fprops.
by symmetry; apply: (cdivides_pr2 (BS_prod bB sB) bB sB bs).
Qed.

Lemma cdistrib_prod2_sub a b c: inc a Bnat -> inc b Bnat -> inc c Bnat
  -> c <=c b ->
  a *c (b -c c ) = (a *c b ) -c (a *c c ).
Proof.
move=> aB bB cB le; symmetry; apply: cdiff_pr2; fprops.
rewrite - cprod_sumDl csumC cdiff_pr //.
Qed.

Lemma cdivides_and_difference a a' b:
  a' <=c a -> b %|c a -> b %|c a'
  -> [/\ b %|c (a -c a'), (a' %/c b ) <=c (a %/c b ) &
    (a -c a') %/c b = (a %/c b ) -c (a' %/c b )].
Proof.
move=> le d1 d2.
move: (cdivides_pr d1)(cdivides_pr d2)=> am bm.
set s := (a %/c b) -c (a' %/c b).
move: d1 d2 => [aB bB _][a'B _ _].
move: (BS_quo aB bB)(BS_quo a'B bB) => q1 q2.
have q3: (a' %/c b) <=c (a %/c b).
  case: (equal_or_not b \0 c) => bnz.
    rewrite bnz ! cquo_zero; fprops.
  rewrite am bm in le.
  apply: (cprod_le_simplifiable bB q2 q1 bnz le).
have ->: (a -c a' = b *c s).
  by rewrite /s cdistrib_prod2_sub // -am -bm.
have sB:inc s Bnat by rewrite /s; fprops.
split => //; first by apply: cdivides_pr1 =>//.
case: (equal_or_not b card_zero) => bs.
  rewrite {2} /s bs ! cquo_zero cdiff_n_n; fprops.
by symmetry; apply: (cdivides_pr2 (BS_prod bB sB) bB sB bs).
Qed.

EIII-5-7 Expansion to base b

Lemma b_power_k_large a b: inc a Bnat -> inc b Bnat ->
  \1 c <c b -> a <> \0 c -> exists k,
    [/\ inc k Bnat, (b ^c k ) <=c a & a <c (b ^c (succ k ))].
Proof.
move=> aB bB l1b naz.
set (prop:= fun k=> inc k Bnat /\ a <c (b ^c k )).
have pB:(forall x, prop x -> inc x Bnat) by move => k [].
have pz: ~(prop card_zero ).
  rewrite /prop cpowx0; move=> [_ a1].
   move: (card_ge1 (CS_Bnat aB) naz)=> h; co_tac.
have exp:(exists x, prop x).
  exists a; split=> //; apply: cpow_M1lt;fprops.
move: (least_int_prop1 pB pz exp)=> [k [kN pks npk]].
ex_tac; last by move: pks => [_ res].
case: (Bnat_to_el (BS_pow bB kN) aB) => //.
by move=>h; case: npk.
Qed.

Definition expansion f b k :=
  [/\ inc b Bnat, inc k Bnat, \1 c <c b &
  [/\ fgraph f, domain f = Bint k &
  forall i, inc i (domain f) -> (Vg f i ) <c b]].

Definition expansion_value f b :=
  card_sumb (domain f) (fun i=> (Vg f i ) *c (b ^c i )).

Section Base_b_expansion.
Variables f g b k k': Set.
Variable Exp: expansion f b k.
Variable Expg: expansion g b (succ k').

Lemma expansion_prop0P i:
   (inc i (domain f)) <-> i <c k.
Proof. move: Exp => [_ kn _ [_ -> _]];exact: (BintP kn). Qed.

Lemma expansion_prop1 i:
  i <c k -> inc (Vg f i) Bnat.
Proof.
move: Exp => [bN kn _ [_ d v]] /expansion_prop0P idf.
move: (v _ idf) => [h _ ]; Bnat_tac.
Qed.

Lemma expansion_prop2:
   finite_int_fam (Lg (domain f) (fun i=> (Vg f i ) *c (b ^c i ))).
Proof.
move: Exp => [bB kB b2 [fgf df vf]].
hnf; rewrite /allf; bw; split.
  move=> i idf; bw; move /expansion_prop0P: idf => idf.
  apply: (BS_prod (expansion_prop1 idf) (BS_pow bB (BS_lt_int idf kB))).
by rewrite df; apply: finite_Bint.
Qed.

Lemma expansion_prop3: inc (expansion_value f b) Bnat.
Proof.
rewrite /expansion_value; apply: finite_sum_finite.
apply: expansion_prop2.
Qed.

Lemma expansion_prop4: cardinalp k' -> inc k' Bnat.
Proof. move: Expg => [_ kB' _ _] ck; apply: BS_nsucc => //. Qed.

Lemma expansion_prop5: cardinalp k' ->
  expansion (restr g (Bint k')) b k'.
Proof.
move => bk'; move: (expansion_prop4 bk')=> k'n.
move: (Bint_M k'n) => subi.
move: Expg => [bB kB b2 [fgf df vf]].
have dr: (domain (restr g (Bint k')) = Bint k') by bw; ue.
split;fprops; split; fprops.
rewrite dr; move=> i ic; bw; try ue.
by apply: vf; rewrite df; apply: subi.
Qed.

Lemma expansion_prop6: cardinalp k' -> inc (Vg g k') Bnat.
Proof.
move => bk'; move: (expansion_prop4 bk')=> k'n.
move: Expg => [bN kn _ [_ d v]].
have kd: (inc k' (domain g)) by rewrite d; apply:Bint_si.
move: (v _ kd)=> [h _]; Bnat_tac.
Qed.

Lemma expansion_prop7: cardinalp k' ->
  (expansion_value g b ) =
   (expansion_value (restr g (Bint k')) b )
   +c (Vg g k' *c (b ^c k')).
Proof.
move => bk'; move: (expansion_prop4 bk')=> k'n.
pose h i := (Vg g i ) *c (b ^c i ).
have ->: (Vg g k') *c (b ^c k') = h k' by [].
rewrite /expansion_value.
move: (induction_on_sum h k'n); simpl.
have dg: domain g = (Bint (succ k'))
  by move: Expg=> [_ _ _ [_ dg _]].
rewrite -dg; set kk:= (Lg (domain g) h) ; move=> <-.
congr (card_sum _ +c (h k')).
move: (Bint_M k'n) => ii.
have fgg: fgraph g by move : Expg=> [_ _ _ []].
bw;apply: Lg_exten; move=> x xdf /=; bw; ue.
Qed.

End Base_b_expansion.

Lemma expansion_prop8 f b k x:
  let h:= Lg (Bint (succ k)) (fun i=> Yo (i =k) x (Vg f i)) in
expansion f b k ->
   inc x Bnat -> x <c b ->
    (expansion h b (succ k) /\
      expansion_value h b =
      (expansion_value f b ) +c ((b ^c k ) *c x )).
Proof.
move=> h Expf xB xb.
move: Expf => [bB kB b2 [fgf df vf]].
have eg: (expansion h b (succ k)).
  red; rewrite /h; bw;split;fprops; split; fprops.
  move=> i idh; bw; Ytac ik => //; apply: vf.
  rewrite df; move: (Bint_pr4 kB)=> [p1 p2].
  move: idh; rewrite - p1; case /setU1_P => //.
have ck: cardinalp k by fprops.
rewrite (expansion_prop7 eg ck).
split; first by exact.
have ->:(restr h (Bint k)= f).
  rewrite /h; symmetry.
  move: (Bint_M kB) => si.
  apply: fgraph_exten=> //.
     fprops.
     bw; fprops.
  rewrite df; move=> y ydf /=; bw; fprops.
  by move: ydf => /(BintP kB) [_ yk]; Ytac0.
have -> //: (Vg h k *c (b ^c k) = (b ^c k) *c x).
by rewrite cprodC /h; bw;[ Ytac0 | apply: (Bint_si kB)].
Qed.

Lemma expansion_prop9 f b k: expansion f b k ->
   (expansion_value f b ) <c (b ^c k ).
Proof.
move=> Exp.
have kB: inc k Bnat by move: Exp => [bB kB _ _].
move: k kB f Exp.
apply: cardinal_c_induction.
  rewrite cpowx0.
  move=> g [bB _ b2 [fgf df _]].
  rewrite /expansion_value df Bint_co00 /card_sumb csum_trivial.
    apply: card_lt_01.
  bw.
move=> n nB pn g eg.
have cn: (cardinalp n) by fprops.
rewrite (expansion_prop7 eg cn).
move: (expansion_prop5 eg cn) => er.
move: (pn _ er).
move : eg => [bB _ b2 [fgf df vg]].
rewrite pow_succ //.
move: (expansion_prop3 er).
set (a0:= expansion_value (restr g (Bint n)) b).
set (b0:= b ^c n).
have p1: ((Vg g n) <c b).
  by apply: vg; rewrite df; apply:Bint_si.
have cB: inc (Vg g n) Bnat by move: p1 => [aux _]; Bnat_tac.
have b0B: inc b0 Bnat by rewrite /b0; apply: BS_pow.
set c0:= (Vg g n) *c b0.
move => a0B h.
have le1: (a0 +c c0) <c (b0 +c c0).
  apply: csum_Mlteq => //; rewrite /c0; fprops.
suff le2: (b0 +c c0) <=c (b0 *c b) by co_tac.
have cb: cardinalp b0 by fprops.
have ->: b0 +c c0 = b0 *c (succ (Vg g n)).
  rewrite (Bsucc_rw cB) cprod_sumDl (cprod1r cb) cprodC csumC //.
apply: cprod_Mlele; fprops.
by apply /(card_le_succ_ltP _ cB).
Qed.

Lemma expansion_prop10 f b k: cardinalp k ->
  expansion f b (succ k) ->
  card_division_prop (expansion_value f b) (b ^c k) (Vg f k)
  (expansion_value (restr f (Bint k)) b).
Proof.
move=> ck ie.
split.
  rewrite csumC cprodC.
  apply: expansion_prop7 =>//.
apply: expansion_prop9; apply: expansion_prop5 =>//.
Qed.

Lemma expansion_unique f g b k:
  expansion f b k -> expansion g b k ->
  expansion_value f b = expansion_value g b -> f = g.
Proof.
move=> ef eg sm.
have kB: inc k Bnat by move: eg => [_ kB _ _ ].
move: k kB f g sm ef eg.
apply: (cardinal_c_induction).
  rewrite /expansion Bint_co00.
  move=> f1 g1 sv [bB _ _ [fgf df _]] [_ _ _ [fgg dg _]].
  apply: fgraph_exten; [exact | exact | ue | ].
  by rewrite df;move=> x /in_set0.
move=> n nB pn f g sv ef eg.
have cn: cardinalp n by fprops.
move: (expansion_prop10 cn ef) => p1.
move: (expansion_prop10 cn eg) => p2.
rewrite sv in p1.
move: (expansion_prop5 ef cn) => er1.
move: (expansion_prop5 eg cn) => er2.
move:(expansion_prop3 eg) => egB.
have bB: inc b Bnat by move: ef => [bB _].
have cpB: inc (b ^c n) Bnat by fprops.
move: (expansion_prop6 ef cn) => q1B.
move: (expansion_prop6 eg cn) => q2B.
move: (expansion_prop3 er1) => r1B.
move: (expansion_prop3 er2) => r2B.
have bnz: (b ^c n <> card_zero).
  have [_ b0]: (\0 c <c b).
    have aux: \0 c <=c \1 c by fprops.
    move: ef => [_ _ n1b _]; co_tac.
  by apply: cpow_nz => bz; case: b0.
move: (card_division_unique egB cpB q1B r1B q2B r2B bnz p1 p2)=> [pt r].
have aux: (restr f (Bint n) = restr g (Bint n)).
  apply: pn =>//.
move:ef eg=> [_ _ _ [fgf df _]] [_ _ _ [fgg dg _]].
apply: fgraph_exten; [ exact | exact | ue | ].
move=> x xdf.
case: (equal_or_not x n); first by move => ->.
move=> xn.
have xc: (inc x (Bint n)).
  move: xdf; rewrite df;
  move /(BintP(BS_succ nB)) /(card_lt_succ_leP nB) => h.
  by apply /(BintP nB); split.
have <-: (Vg (restr f (Bint n)) x = Vg f x).
  bw; rewrite df; apply: Bint_M =>//.
have <-: (Vg (restr g (Bint n)) x = Vg g x).
  bw; rewrite dg; apply: Bint_M =>//.
ue.
Qed.

Lemma expansion_prop11 f g b k: cardinalp k ->
  expansion f b (succ k) -> expansion g b (succ k) ->
  (Vg f k ) <c (Vg g k ) ->
  (expansion_value f b ) <c (expansion_value g b ).
Proof.
move=> ck ef eg ltk.
rewrite (expansion_prop7 ef ck) (expansion_prop7 eg ck).
move: (expansion_prop5 ef ck) => ef1.
move: (expansion_prop5 eg ck) => eg1.
move: (expansion_prop9 ef1).
move: (expansion_prop3 ef1).
move: (expansion_prop3 eg1).
set u:= expansion_value _ _; set v:= expansion_value _ _.
move=> uB vB vp.
move: (expansion_prop4 ef ck) => kB.
move: (expansion_prop6 ef ck) => fB.
move: (expansion_prop6 eg ck) => gB.
set (B:= card_pow b k).
have bB: inc b Bnat by move: ef => [h _].
have BB: (inc B Bnat) by rewrite /B; fprops.
have bb: (B <=c B) by rewrite /B;fprops.
apply: (@card_lt_leT _ (B +c ((Vg f k) *c B))).
  apply: csum_Mlteq; fprops.
apply: (@card_leT _ ((Vg g k) *c B)); last first.
  rewrite csumC; apply: csum_M0le; fprops.
move /(card_le_succ_ltP _ fB): ltk => ltk.
move: (cprod_Mlele ltk bb).
rewrite (Bsucc_rw fB) cprod_sumDr.
by rewrite (cprod1l (CS_Bnat BB)) csumC.
Qed.

Lemma expansion_restr1 f b k l:
  expansion f b k -> l <=c k ->
  expansion (restr f (Bint l)) b l.
Proof.
move=> [bB bK b2 [fgf df vg]] lk.
have lB: inc l Bnat by Bnat_tac.
split; fprops; split; fprops; bw => i idx; bw; apply: vg; rewrite df.
exact: (Bint_M1 bK lk).
Qed.

Lemma expansion_restr2 f b k l:
  expansion f b k -> l <=c k ->
  (forall i, l <=c i -> i <c k -> Vg f i = \0 c) ->
  expansion_value (restr f (Bint l)) b = expansion_value f b.
Proof.
move=> ef lk p.
set g := fun i => expansion_value (restr f (Bint i)) b.
have <-: (g k = expansion_value f b).
  move: ef => [bB bK b2 [fgf df vg]].
  rewrite /g -df restr_to_domain //.
set r := fun i=> g l = g i.
change (r k).
have kB: inc k Bnat by move: ef => [bB bK _].
have lB: inc l Bnat by Bnat_tac.
have: inc k (interval_cc Bnat_order l k) by apply/ Bint_ccP1;fprops.
apply: (cardinal_c_induction3_v (r:=r) lB kB); first by trivial.
move=> i /(Bint_coP1 lB kB) [li ik]; rewrite /r => ->.
have iB: inc i Bnat by move: ik => [ik _]; Bnat_tac.
have ci: cardinalp i by fprops.
have ik': (succ i) <=c k by apply /card_le_succ_lt0P; fprops.
move:(expansion_restr1 ef ik').
set F := (restr f (Bint (succ i))).
move=> eF.
rewrite /g (expansion_prop7 eF ci).
set G := (restr F (Bint i)).
have si: sub (Bint (succ i)) (domain f).
  move: ef => [bB bK b2 [fgf df vg]].
  rewrite df; apply: Bint_M1;fprops.
have ->: (restr f (Bint i) = G).
move: ef => [bB bK b2 [fgf df vg]].
rewrite /G /F double_restr //.
apply: Bint_M =>//.
have ->: (Vg F i = card_zero).
  move: ef => [bB bK b2 [fgf df vg]].
  rewrite /F; bw; try apply: p=>//.
  apply:Bint_si =>//.
rewrite cprodC cprod0r csum0r //.
rewrite /expansion_value/card_sumb/card_sum; fprops.
Qed.

Lemma expansion_prop12 f g b kf kg l n:
  n <=c kf -> n <=c kg -> l <c n ->
  (forall i, n <=c i -> i <c kf -> Vg f i = \0 c) ->
  (forall i, n <=c i -> i <c kg -> Vg g i = \0 c) ->
  (forall i, l <c i -> i <c n -> Vg f i = Vg g i) ->
  expansion f b kf -> expansion g b kg ->
  (Vg f l ) <c (Vg g l ) ->
  (expansion_value f b ) <c (expansion_value g b ).
Proof.
move=> nkf nkg ln pf pg pfg ef eg vl.
move: (expansion_restr1 ef nkf).
rewrite -(expansion_restr2 ef nkf pf).
move: (expansion_restr1 eg nkg).
rewrite -(expansion_restr2 eg nkg pg).
set F := (restr f (Bint n)).
set G := (restr g (Bint n)).
move=> eG eF; clear pf pg.
have kfB: inc kf Bnat by move: ef => [_ h _].
have nB: inc n Bnat by Bnat_tac.
have lB: inc l Bnat by move: ln => [ln _]; Bnat_tac.
have pFG: forall i, l <c i -> i <c n -> Vg F i = Vg G i.
  move=> i i1 i2; move: (pfg _ i1 i2).
  have ii: inc i (Bint n) by apply /BintP.
  move: ef eg => [_ _ _ [fgf df vf]] [_ kgB b2 [fgg dg vg]].
  rewrite /F/G; bw.
have vL: (Vg F l) <c (Vg G l).
  have ii: inc l (Bint n) by apply /BintP.
  move: ef eg => [_ _ _ [fgf df vf]] [_ kgB b2 [fgg dg vg]].
  rewrite /F/G; bw.
clear pfg vl ef eg.
set fi := fun i => expansion_value (restr F (Bint i)) b.
set gi := fun i => expansion_value (restr G (Bint i)) b.
have <-: (fi n = expansion_value F b).
  move: eF => [bB bK b2 [fgf df vg]].
  rewrite /fi -df restr_to_domain //.
have <-: (gi n = expansion_value G b).
  move: eG => [bB bK b2 [fgf df vg]].
  rewrite /gi -df restr_to_domain //.
pose r i := (fi i ) <c (gi i ).
change (r n).
have cl2: inc (succ l) Bnat by fprops.
have cl0: (succ l) <=c n by apply /card_le_succ_ltP.
have rz: (r (succ l)).
  rewrite /r /fi /gi.
  have cl: cardinalp l by fprops.
  have cl1: finite_c l by fprops.
  move: (expansion_restr1 eF cl0) => ef1.
  move: (expansion_restr1 eG cl0) => eg1.
  apply: (expansion_prop11 cl ef1 eg1).
  move: eF eG => [_ _ _ [fgf df vf]] [_ kgB b2 [fgg dg vg]].
  have il: inc l (Bint (succ l)).
    by apply:Bint_si.
  bw.
have: inc n (interval_cc Bnat_order (succ l) n).
   rewrite Bint_ccP1;fprops.
apply: (cardinal_c_induction3_v (r:=r) cl2 nB rz).
clear rz.
move=> i /(Bint_coP1 cl2 nB) [li ik] ri.
have iB: inc i Bnat by move: ik => [ik _]; Bnat_tac.
have ci: cardinalp i by fprops.
have ik': (succ i) <=c n by by apply /card_le_succ_ltP.
move:(expansion_restr1 eF ik').
move:(expansion_restr1 eG ik').
set f1 := (restr F (Bint (succ i))).
set g1 := (restr G (Bint (succ i))).
move=> ef1 eg1; move: ri.
rewrite /r /fi /gi (expansion_prop7 ef1 ci).
rewrite (expansion_prop7 eg1 ci).
set f2 := (restr f1 (Bint i)).
set g2 := (restr g1 (Bint i)).
have si: sub (Bint (succ i)) (domain F).
  move: eF => [bB bK b2 [fgf df vg]].
  rewrite df; apply: Bint_M1; fprops.
have sj: sub (Bint (succ i)) (domain G).
  move: eG => [bB bK b2 [fgf df vg]].
  rewrite df; apply: Bint_M1; fprops.
have ->: (restr F (Bint i) = f2).
  move: eF => [bB bK b2 [fgf df vg]].
  rewrite /f2 /f1 double_restr //.
  apply: Bint_M1; fprops.
have ->: (restr G (Bint i) = g2).
move: eG => [bB bK b2 [fgf df vg]].
rewrite /g2 /g1 double_restr //.
by apply: Bint_M1;fprops.
have ->: (Vg f1 i = Vg g1 i).
  have ii:inc i (Bint (succ i)) by apply:Bint_si.
  move: eF => [bB bK b2 [fgf df vg]].
  move: eG => [_ _ _ [fgf' df' vg']].
  rewrite /f1 /g1; bw; try apply: pFG=>//.
  apply/card_le_succ_lt0P; fprops.
have isi: i <=c (succ i) by fprops.
move:(expansion_restr1 eg1 isi) => ef2.
move:(expansion_restr1 ef1 isi) => eg2.
apply: csum_Mlteq.
  have bB: inc b Bnat by move: ef1 => [ h _].
  apply: BS_prod; fprops.
  apply: (expansion_prop1 ef1); fprops.
apply: (expansion_prop3 eg2).
Qed.

Lemma expansion_prop13 f g b kf kg l:
  kf <=c l -> l <c kg ->
  expansion f b kf -> expansion g b kg ->
  Vg g l <> \0 c ->
  (expansion_value f b ) <c (expansion_value g b ).
Proof.
move=> le1 le2 ef eg vnz.
apply: (@card_lt_leT _ (b ^c kf)).
apply: (expansion_prop9 ef).
move: eg => [bB bK b2 [fgf df vg]].
rewrite /expansion_value /card_sumb.
set F:= Lg _ _.
have fgF: fgraph F by rewrite /F;fprops.
have dF: domain F = Bint kg by rewrite /F -df; bw.
have alc: (forall x, inc x (domain F) -> cardinalp (Vg F x)).
  rewrite dF -df /F => x xdf; bw; fprops.
have ldf: inc l (domain F) by rewrite dF; apply /BintP.
set j:= singleton l.
have sj: sub j (domain F) by move => t /set1_P ->.
move: (csum_increasing1 alc sj).
rewrite (csum_trivial4 _ _ ) (card_card (alc _ ldf)).
suff: (b ^c kf) <=c (Vg F l) by move => p1 p2; co_tac.
have ldg: inc l (domain g) by rewrite df; apply /BintP.
rewrite /F; bw.
have bnz: b<> card_zero by move=>h; rewrite h in b2; case: (card_lt0 b2).
apply: (@card_leT _ (b ^c l)).
  apply: cpow_Mlele; fprops.
rewrite cprodC.
apply: cprod_M1le => //; rewrite /card_pow; fprops.
Qed.

Lemma expansion_prop14 f g b kf kg:
  expansion f b kf -> expansion g b kg ->
  (expansion_value f b ) <c (expansion_value g b ) ->
  (exists l, [/\ kf <=c l, l <c kg & Vg g l <> \0 c])
\/ (
  exists l n,
  [/\ n <=c kf, n <=c kg, l <c n &
  [/\ (forall i, n <=c i -> i <c kf -> Vg f i = \0 c),
  (forall i, n <=c i -> i <c kg -> Vg g i = \0 c) ,
  (forall i, l <c i -> i <c n -> Vg f i = Vg g i) &
   (Vg f l ) <c (Vg g l )]]).
Proof.
move=> ef eg lt.
have kfb:inc kf Bnat by move: ef => [_ h _].
have kgb:inc kg Bnat by move: eg => [_ h _].
have [n [nf ng nfg]]: exists n,
   [/\ n <=c kf, n <=c kg & (n = kf \/ n = kg)].
  have k1:cardinalp kf by fprops.
  have k2:cardinalp kg by fprops.
  case: (card_le_to_ee k1 k2)=> aux; [exists kf | exists kg];split;fprops.
case: (p_or_not_p (forall i, n <=c i -> i <c kg -> Vg g i = \0 c)); last first.
  move=> h.
  have [i [ni ik Vz]]: (exists i, [/\ n <=c i, i <c kg & Vg g i <> \0 c]).
   ex_middle h'.
    case: h; move=> i i1 i2.
    case: (p_or_not_p (Vg g i = \0 c)) =>// h''; case: h'; exists i => //.
  left; exists i; split => //.
  case: nfg; [by move=> <- | move=> nk; rewrite nk in ni; co_tac ].
move=> pB; right.
case: (p_or_not_p (forall i, n <=c i -> i <c kf -> Vg f i = \0 c)); last first.
  move=> h.
  have [i [ni ik Vz]]: (exists i, [/\ n <=c i, i <c kf & Vg f i <> \0 c]).
    ex_middle h'; case: h; move=> i i1 i2.
    case: (p_or_not_p (Vg f i = \0 c)) =>// h''; case: h'; exists i; split => //.
  have fi: kg <=c i.
  case: nfg; [move=> nk; rewrite nk in ni; co_tac | by move=> <-].
  move: (expansion_prop13 fi ik eg ef Vz) =>[ br _].
  co_tac.
move=> pA.
have nB: inc n Bnat by case: nfg; move=> -> //.
have pC: exists2 l, l <c n& (Vg f l) <> (Vg g l).
  move: (expansion_restr2 ef nf pA) => hf.
  move: (expansion_restr2 eg ng pB) => hg.
  ex_middle bad.
  have eq: (restr f (Bint n) = restr g (Bint n)).
    move: ef eg => [bB bK b2 [fgf df vf]][_ _ _ [fgg dg vg]].
    have s1: sub (Bint n) (domain g).
      rewrite dg; apply: Bint_M1;fprops.
    have s2: sub (Bint n) (domain f).
      rewrite df; apply: Bint_M1;fprops.
    have drf: (domain (restr f (Bint n)) = Bint n) by bw.
    have drg: (domain (restr g (Bint n)) = Bint n) by bw.
    apply: fgraph_exten; fprops.
      ue.
    rewrite drf => x xdf; bw.
    ex_middle nx; case: bad; exists x => //.
    move: xdf => /(BintP nB) => //.
  move: lt;rewrite -hf -hg eq; move => [_ ne]; case: ne; apply: refl_equal.
have [l [lp ln Vl]]: exists l,
    [/\ (forall i : Set, l <c i -> i <c n -> Vg f i = Vg g i),
      l <c n & (Vg f l ) <> (Vg g l )].
  set z:= Zo Bnat (fun l => l <c n /\ Vg f l <> Vg g l).
  have nz: nonempty z.
    move: pC => [l lp]; exists l; apply: Zo_i => //.
    move:lp => [lp _];Bnat_tac.
  have pa: (forall a, inc a z -> cardinalp a).
    move=> a /Zo_P [aB _ ]; fprops.
  move: (wordering_cardinal_le_pr pa) => [wor sr].
  move: (worder_total wor) => tor.
  have zc: sub z (Bint n).
    by move=> t /Zo_P [_ [p1 _]]; apply /BintP.
  have fsz: finite_set z.
   by apply: (sub_finite_set zc); apply: finite_Bint.
  have sw: sub z (substrate (graph_on cardinal_le z)) by rewrite sr; fprops.
  move: (finite_subset_torder_greatest tor fsz sw nz)=> [l []].
  move: wor => [or _].
  aw; move=> lz lp; exists l.
  move: (lz); move => /Zo_P [lB [ln Vl]]; split => //.
  move=> i li lin.
  have iB: inc i Bnat by move: lin => [lin _ ]; Bnat_tac.
  case: (equal_or_not (Vg f i) (Vg g i)) => // h.
  have iz: inc i z by apply: Zo_i => //.
  move: (iorder_gle1 (lp _ iz)) => /graph_on_P1 [_ _ il]; co_tac.
exists l; exists n; split => //.
  have p1: cardinalp (Vg f l).
    move: ef =>[bB bK b2 [fgf df vf]].
    have ldf: (inc l (domain f)) by rewrite df; apply /BintP => //; co_tac.
    by move: (vf _ ldf)=> [[res _] _ ].
  have p2: cardinalp (Vg g l).
    move: eg =>[bB bK b2 [fgf df vf]].
    have ldf: (inc l (domain g)) by rewrite df;apply /BintP => //; co_tac.
    by move: (vf _ ldf)=> [[res _] _ ].
  case: (card_le_to_el p2 p1) => //.
  move=> h.
  have p3: (Vg g l) <c (Vg f l) by split => //; apply: nesym.
  have lp' : forall i, l <c i -> i <c n -> Vg g i = Vg f i.
    by move=> i i1 i2; symmetry;move: (lp _ i1 i2).
  move: (expansion_prop12 ng nf ln pB pA lp' eg ef p3) => [p4 _].
  co_tac.
Qed.

Lemma expansion_exists1 a b k:
  inc b Bnat -> \1 c <c b -> inc k Bnat ->
  inc a Bnat -> a <c (b ^c k ) ->
  exists2 f, expansion f b k & expansion_value f b = a.
Proof.
move=> bB b1 kB; move: k kB a.
apply: cardinal_c_induction.
  rewrite cpowx0 => c cB c1.
  exists (Lg emptyset (fun _ => card_zero)) => //;bw.
    split;fprops; split; fprops.
      by bw; rewrite - Bint_co00.
    by bw; move=> i /in_set0.
  rewrite /expansion_value/card_sumb; bw; rewrite csum_trivial; bw.
  move: c1; rewrite - succ_zero; move / (card_lt_succ_leP BS0) => aux.
  by symmetry; apply: card_le0.
move=> n nB pn c cB cp.
set (b0:= b ^c n).
have b0B: (inc b0 Bnat) by rewrite /b0; fprops.
have Bz: (b0 <> card_zero).
  have aux:(\0 c <c b) by move: card_lt_01 => aux'; co_tac.
  have bnz: b<> card_zero by move: aux => [_]; apply: nesym.
  apply: (cpow_nz bnz).
move: (card_division_exists cB b0B Bz) => [q [r [qB rB [aux lt]]]].
rewrite /b0 in lt.
move: (pn _ rB lt) => [f ise ev].
have p1: (b0 *c q) <c (b0 *c b).
  have p2: ((b0 *c q) <=c c).
    rewrite aux; apply: csum_M0le; fprops.
  have p3: (inc (b0 *c q) Bnat) by fprops.
  rewrite /b0 - pow_succ -/b0; fprops.
  co_tac.
move: (cprod_lt_simplifiable b0B qB bB Bz p1) => qb.
move: (expansion_prop8 ise qB qb).
set F:= (Lg _ _).
move=> [s1 s2]; exists F => //.
rewrite s2 ev aux csumC /b0; apply: refl_equal.
Qed.

Lemma expansion_exists a b: inc a Bnat -> inc b Bnat ->
  \1 c <c b -> exists k f,
    (expansion f b k /\ expansion_value f b = a ).
Proof.
move=> aB bB b1; exists a.
have [f pa pb]:exists2 f, expansion f b a & expansion_value f b = a.
  by apply: expansion_exists1 => //; apply: cpow_M1lt; fprops.
by exists f.
Qed.

Definition eqmod a b B:= a %%c B = b %%c B.

Section ModuloProps.
Variable B: Set.
Hypothesis Bn: inc B Bnat.
Hypothesis Bnz: B <> \0 c.

Lemma crem_prop a b: inc a Bnat -> inc b Bnat ->
  eqmod ((B *c a ) +c b) b B.
Proof.
move=> aB bB; rewrite /eqmod.
move: (card_division bB Bn Bnz).
set q := b %/c B; set r := b %%c B.
move=> [q1B r1B [aeq r1p]].
rewrite aeq csumA - cprod_sumDl.
set q2:= (a +c q).
have q2B: inc q2 Bnat by rewrite /q2; apply: BS_sum.
set A:= ((B *c q2) +cr).
have dp: (card_division_prop A B q2 r) by split;[apply: refl_equal | done].
move: (cquorem_pr (BS_sum (BS_prod Bn q2B) r1B) Bn q2B r1B dp).
by move=> [_ h]; symmetry.
Qed.

Lemma crem_sum a b: inc a Bnat -> inc b Bnat ->
  eqmod (a +c b) ((a %%c B ) +c (b %%c B )) B.
Proof.
move=> aB bB.
move: (card_division aB Bn Bnz) (card_division bB Bn Bnz).
rewrite /card_division_prop.
set q1:= a %/cB; set q2:= b %/c B; set r1:= a %%c B; set r2:= b %%c B.
move=> [q1B r1B [aeq r1p]][q2B r2B [beq r2p]].
rewrite aeq beq.
set t := _ +c _.
have ->: t= (B *c (q1 +c q2)) +c (r1 +c r2).
  rewrite cprod_sumDl csumA.
  set (s1:= B *c q1); set (s2:= B *c q2).
  by rewrite /t (csum_permute24) -/s1 -/s2 csumA.
apply:(crem_prop (BS_sum q1B q2B) (BS_sum r1B r2B)).
Qed.

Lemma crem_mult a b: inc a Bnat -> inc b Bnat ->
  eqmod (a *c b) ((a %%c B ) *c (b %%c B )) B.
Proof.
move=> aB bB.
move: (card_division aB Bn Bnz) (card_division bB Bn Bnz).
set q1:= a %/cB; set q2:= b %/c B; set r1:= a %%c B; set r2:= b %%c B.
rewrite /card_division_prop.
move=> [q1B r1B [aeq r1p]][q2B r2B [beq r2p]].
rewrite aeq beq.
rewrite cprod_sumDl(cprodC B q2) cprodA (cprodC _ B).
set v := ((B *c q1) +c r1) *c q2.
rewrite cprod_sumDr - cprodA csumA - cprod_sumDl.
apply: crem_prop ; [apply: BS_sum | ]; apply: BS_prod => //; ue.
Qed.

Lemma eqmod_plus a b a' b': inc a Bnat -> inc b Bnat ->
  inc a' Bnat -> inc b' Bnat ->
  eqmod a a' B -> eqmod b b' B -> eqmod (a +c b) (a' +c b') B.
Proof.
move=> aB bB a'B b'B; rewrite /eqmod => e1 e2.
rewrite (crem_sum aB bB) e1 e2 (crem_sum a'B b'B); reflexivity.
Qed.

Lemma eqmod_mult a b a' b': inc a Bnat -> inc b Bnat ->
  inc a' Bnat -> inc b' Bnat ->
  eqmod a a' B -> eqmod b b' B -> eqmod (a *c b) (a' *c b') B.
Proof.
move=> aB bB a'B b'B e1 e2.
rewrite /eqmod in e1 e2 |- *.
rewrite (crem_mult aB bB) (crem_mult a'B b'B) e1 e2; reflexivity.
Qed.

Lemma eqmod_rem a: inc a Bnat -> eqmod a (a %%c B) B.
Proof.
move=> aB.
rewrite {1} (cdiv_pr aB Bn); apply: crem_prop; fprops.
Qed.

Lemma eqmod_succ a a': inc a Bnat -> inc a' Bnat ->
  eqmod a a' B -> eqmod (succ a) (succ a') B.
Proof.
move=> aB a'B e1.
rewrite !card_succ_pr4; fprops; apply: eqmod_plus => //; fprops.
Qed.

Lemma eqmod_pow1 a n: inc a Bnat -> inc n Bnat ->
  eqmod a \1 c B -> eqmod (a ^c n) \1 c B.
Proof.
move=> aB nB h; move: n nB.
apply: cardinal_c_induction; first by rewrite cpowx0.
move=> n nB h1.
move: (eqmod_mult (BS_pow aB nB) aB BS1 BS1 h1 h).
rewrite (pow_succ _ nB) (cprod1r); fprops.
Qed.

Lemma eqmod_pow2 a b n: inc a Bnat -> inc b Bnat -> inc n Bnat ->
  eqmod a \1 c B -> eqmod (b *c (a ^c n )) b B.
Proof.
move=> aB bB nB h.
move: (eqmod_pow1 aB nB h) => h2.
have aux: eqmod b b B by [].
move: (eqmod_mult bB (BS_pow aB nB) bB BS1 aux h2).
rewrite cprod1r; fprops.
Qed.

Lemma eqmod_pow3 f b k: expansion f b k ->
   eqmod b \1 c B -> eqmod (expansion_value f b) (card_sum f) B.
Proof.
move=> ep b1.
have kB: inc k Bnat by move: ep => [bB kB _].
move: k kB f ep.
set (p:= fun n => forall f, expansion f b n ->
  eqmod (expansion_value f b) (card_sum f) B).
apply: (cardinal_c_induction (r:=p)).
  move=> g [bB _ b2 [fgf df _]].
  have dge: domain g = emptyset by move: df; rewrite Bint_co00.
  rewrite /expansion_value/card_sumb dge !csum_trivial //; bw.
move=> n nB pn g eg.
have cn: (cardinalp n) by fprops.
rewrite (expansion_prop7 eg cn).
move: (expansion_prop5 eg cn) => er.
move: (eg) => [bB _ _ [fgg dg _]].
move: (BS_succ nB) => snB.
have si: sub (Bint n) (domain g).
  rewrite dg; apply: (Bint_M nB).
have ->: (card_sum g =
   (card_sum (restr g (Bint n))) +c (Vg g n)).
  pose h w := \0 c +c (Vg g w ).
  have hp: forall x, inc x (domain g) -> h x = Vg g x.
    move=> x; rewrite dg; move /(BintP snB) => p1.
    move: (expansion_prop1 eg p1) => p2.
    rewrite /h; aw; fprops.
  move: (induction_on_sum h nB); simpl.
  have ->: h n = Vg g n by apply: hp; rewrite dg; apply:Bint_si.
  rewrite /card_sumb.
  have ->: (Lg (Bint (succ n)) h = g).
    apply: fgraph_exten; fprops; first by symmetry;bw.
    bw; move=> x xd /=; bw; apply: hp; ue.
  have ->: (Lg (Bint n) h = (restr g (Bint n))).
    apply: fgraph_exten; fprops.
      by bw; rewrite (restr_d fgg si).
    bw; move=> x xb /=; bw; apply: (hp _ (si _ xb)).
  by move => ->.
have p1: inc (Vg g n) Bnat by apply: (expansion_prop1 eg (card_lt_succ nB)).
have p2: inc ((Vg g n) *c (b ^c n)) Bnat.
   apply: (BS_prod p1 (BS_pow bB nB)).
have p3: inc (card_sum (restr g (Bint n))) Bnat.
  apply: finite_sum_finite_aux; last by exact.
  split => //.
    move=> i; rewrite dg; move /(BintP snB).
    apply: (expansion_prop1 eg).
  by rewrite dg; apply: finite_Bint.
apply: (eqmod_plus (expansion_prop3 er) p2 p3 p1 (pn _ er)).
apply: (eqmod_pow2 bB p1 nB b1).
Qed.

End ModuloProps.

Definition card_five := succ card_four.
Definition card_ten := card_five +c card_five.
Notation "\10c" := card_ten.

Lemma BS5 : inc card_five Bnat.
Proof. apply: (BS_succ BS4). Qed.

Lemma BS10 : inc \10 c Bnat.
Proof. apply: (BS_sum BS5 BS5). Qed.

Lemma card_plus_3_2: \3 c +c \2 c = card_five.
Proof.
rewrite /card_five (Bsucc_rw BS4) /card_four (Bsucc_rw BS3).
by rewrite - csumA card_two_pr.
Qed.

Lemma card_mult_3_3: \10 c = succ (\3 c *c \3 c).
Proof.
have aux: forall n, cardinalp n -> (n +c n ) +c n = n *c \3 c.
  move=> n cn; rewrite /card_three (Bsucc_rw BS2).
  rewrite cprod_sumDl.
  by rewrite (cprod1r cn) cprodC two_times_n.
rewrite / \10 c - card_plus_3_2 - csum_permute24.
set t:= (\3 c +c \3 c).
rewrite csumA -{2} succ_one (csum_via_succ _ BS1) - csumA - (Bsucc_rw BS2).
congr (succ _);apply: aux; apply: (CS_Bnat BS3).
Qed.

Lemma card_mult_10_3: eqmod \10 c \1 c \3 c.
Proof.
rewrite card_mult_3_3 (Bsucc_rw (BS_prod BS3 BS3)).
apply: (crem_prop BS3) BS3 BS1.
rewrite /card_three; apply: succ_nz.
Qed.

Definition expansion_ten f k :=
  [/\ inc k Bnat, fgraph f, domain f = Bint k &
  forall i, inc i (domain f) -> (Vg f i ) <c \10 c].

Lemma divisibiliy_by_three f k: expansion_ten f k ->
  let g:= (Lg (domain f) (fun i=> (Vg f i ) *c (\10 c ^c i ))) in
  eqmod (card_sum g) (card_sum f) \3 c.
Proof.
move=> [p1 p2 p3 p4].
have C30: card_three <> card_zero by rewrite /card_three; apply: succ_nz.
have ep: expansion f \10 c k.
  split => //; first by apply: BS10.
  move: (BS_prod BS3 BS3) => i9B.
  rewrite card_mult_3_3; apply /(card_lt_succ_leP i9B).
  apply: card_ge1; first by fprops.
  apply: (cprod2_nz C30 C30).
exact (eqmod_pow3 BS3 C30 ep card_mult_10_3).
Qed.

Even and odd integers

Definition even_int n := inc n Bnat /\ card_rem n \2 c = \0 c.
Definition odd_int n := inc n Bnat /\ ~ (even_int n ).

Lemma even_double n: inc n Bnat -> even_int (\2 c *c n).
Proof. move => h; split; fprops; exact: (proj33 (cdivides_pr1 h BS2)). Qed.

Lemma half_even n: even_int n -> n = \2 c *c (n %/c \2 c ).
Proof. move => [nB pb]; move: (cdiv_pr nB BS2); rewrite pb; aw; fprops. Qed.

Lemma even_odd_succ n:
  (even_int n -> odd_int (succ n)) /\ (odd_int n -> even_int (succ n)).
Proof.
move: (card2_nz) => n2z.
have aux: forall p m, inc p Bnat -> inc m Bnat ->
  succ (\2 c *c p) <> (\2 c *c m ).
  move=> p m pB mB bad; move: (CS_Bnat pB) => cp.
  have le2:(\2 c <=c \2 c) by fprops.
  have p1: forall a, inc a Bnat -> (succ a ) <=c a -> False.
     move => a ab; move: (card_lt_succ ab) => p1 p2; co_tac.
  case: (card_le_to_el (CS_Bnat mB) cp) => pm.
     move: (cprod_Mlele le2 pm); rewrite - bad; apply:p1; fprops.
  have pa: cardinalp (\2 c *c p +c \1 c) by fprops.
  have pb: cardinalp (\2 c *c p) by fprops.
  move: pm => /(card_le_succ_lt0P cp mB) mp.
  move: (cprod_Mlele le2 mp); rewrite -bad (card_succ_pr4 cp) cprod_sumDl.
  rewrite (cprod1r CS2) - {2} card_two_pr csumA -(card_succ_pr4 pa).
  rewrite -(card_succ_pr4 pb); apply: p1; fprops.
rewrite /odd_int /even_int.
split.
  move=> [nB rz].
  have snB: (inc (succ n) Bnat) by fprops.
  split => //; move => [_ h].
  move:(card_division snB BS2 n2z).
  move:(card_division nB BS2 n2z).
  rewrite rz h /card_division_prop; aw; fprops.
  move=> [q1n _ [np _]] [q2n _ [np' _]].
  by rewrite {1} np in np'; case: (aux _ _ q1n q2n).
move=> [nB h].
move: (card_division nB BS2 n2z)=> [qB rB [nv r2]].
case: (card_lt2 r2) => h1; first by case: h;split => //.
rewrite h1 in nv; clear h1 r2 rB.
have snB: (inc (succ n) Bnat) by fprops.
split => //.
move: (card_division snB BS2 n2z) => [q2B rB [nv2 r2]].
case: (card_lt2 r2) => // h1.
have cn: cardinalp n by fprops.
move: nv2; rewrite h1 {1} card_succ_pr4 //.
set s:= _ *c _ => nv2.
have cs: cardinalp s by rewrite /s; fprops.
move: nv; rewrite - card_succ_pr4; last by fprops.
rewrite {1} (succ_injective cn cs nv2) /s => aux1.
by case: (aux _ _ qB q2B).
Qed.

Lemma even_odd_pred n: inc n Bnat ->
   ( (even_int (succ n) -> odd_int n )
    /\ (odd_int (succ n) -> even_int n )).
Proof.
move: (even_odd_succ n) => [pa pb] nB.
case: (p_or_not_p (even_int n)) => evn; split => //.
  by move => es; move: (pa evn); move => [].
by move => [ta tb]; case: tb; apply pb; split.
Qed.

Lemma even_odd_sum x y:
  [/\ (odd_int x -> odd_int y -> even_int (x +c y)),
    (even_int x -> odd_int y -> odd_int (x +c y)) &
    (even_int x -> even_int y -> even_int (x +c y))].
Proof.
have aux: forall a b, (even_int a -> even_int b -> even_int (a +c b)).
  move => a b [aB ai][bB bi]; split; first by fprops.
  have d1: (\2 c %|c a) by split;fprops.
  have d2: (\2 c %|c b) by split;fprops.
  by move: (cdivides_and_sum d1 d2) => [[_ _ r2] _].
have aux2: forall a b, (even_int a -> odd_int b -> odd_int (a +c b)).
  move => a b ea ob.
  have bB: inc b Bnat by move: ob =>[yb _].
  have sB: inc (a +c b) Bnat by move: ea => [xb _]; fprops.
  move:(proj1 (even_odd_pred sB)); apply.
  rewrite - csum_via_succ //; apply aux => //.
  by apply:(proj2 (even_odd_succ b)).
split;fprops.
move => ox oy.
have yB: inc y Bnat by move: oy =>[yb _].
have sB: inc (x +c y) Bnat by move: ox => [xb _]; fprops.
move:(proj2 (even_odd_pred sB)); apply.
rewrite - csum_via_succ //; rewrite csumC; apply: aux2 => //.
by apply:(proj2 (even_odd_succ y)).
Qed.

Lemma even_zero: even_int \0 c.
Proof. move: (cdivision_of_zero BS2) => [[_ _ res] _]; split;fprops. Qed.

Lemma odd_one: odd_int \1 c.
Proof. by move: (proj1 (even_odd_succ \0 c) even_zero); rewrite succ_zero. Qed.

Lemma even_two: even_int \2 c.
Proof. by move: (proj2 (even_odd_succ \1 c) odd_one); rewrite succ_one. Qed.

EIII-5-8 Combinatorial analysis

Lemma segment_Bnat_order1 n: inc n Bnat -> segment Bnat_order n = n.
Proof.
move=> nB; rewrite (segment_Bnat_order nB).
set_extens t.
  move/(BintP nB) => h.
  by move: (ordinal_cardinal_lt h); move/ord_ltP0 => [_ _].
move => tn.
move: (CS_Bnat(ordinal_transitive OS_omega nB tn)) => ct.
move: (CS_Bnat nB) => cn; move: (ct) (cn) => [ot _] [on _].
apply/(BintP nB); rewrite -(card_card ct).
by apply /(ordinal_cardinal_le2P cn ot) /(ord_ltP on).
Qed.

Definition induction_defined0 (h: fterm2) (a: Set) :=
  transfinite_defined Bnat_order
  (fun u => Yo(source u = \0 c) a
     (h (cpred (source u))(Vf u (cpred (source u))))).

Definition induction_defined (s: fterm) (a: Set) :=
  transfinite_defined Bnat_order
  (fun u => Yo(source u = \0 c) a (s (Vf u (cpred (source u))))).

Lemma induction_defined_pr0 h a (f := induction_defined0 h a):
     [/\ source f = Bnat, surjection f, Vf f \0 c = a &
     forall n, inc n Bnat -> Vf f (succ n) = h n (Vf f n)].
Proof.
rewrite /f /induction_defined0.
set p := (fun u : Set => _).
move: Bnat_order_wor => [wo sr].
move: (transfinite_defined_pr p wo).
set g := (transfinite_defined Bnat_order p).
move=> [pa pb pc].
have p1: forall a, inc a Bnat ->
   source (restriction1 f (segment Bnat_order a))= a.
  move=> b bB; rewrite /restriction1; aw.
  by rewrite segment_Bnat_order1.
rewrite sr in pb pc; split => //.
  by rewrite (pc _ BS0) /restriction_to_segment /p (p1 _ BS0); Ytac0.
move=> n nB; move:(BS_succ nB) => snB;rewrite (pc _ snB) /p (p1 _ snB).
rewrite (Y_false (@succ_nz n)) (cpred_pr2 nB).
congr (h n _); rewrite restriction1_V //; first by fct_tac.
  rewrite segment_Bnat_order // ? pb.
  apply: Bint_S1.
by rewrite (segment_Bnat_order snB); apply: Bint_si.
Qed.

Lemma induction_defined_pr s a (f := induction_defined s a):
    [/\ source f = Bnat, surjection f, Vf f \0 c = a &
     forall n, inc n Bnat -> Vf f (succ n) = s (Vf f n)].
Proof.
rewrite /f /induction_defined.
set p := (fun u : Set => _).
move: Bnat_order_wor => [wo sr].
move: (transfinite_defined_pr p wo).
set g := (transfinite_defined Bnat_order p).
move=> [pa pb pc].
have p1: forall a, inc a Bnat ->
   source (restriction1 f (segment Bnat_order a))= a.
  move=> b bB; rewrite /restriction1; aw.
  by rewrite segment_Bnat_order1.
rewrite sr in pb pc; split => //.
  by rewrite (pc _ BS0) /restriction_to_segment /p (p1 _ BS0); Ytac0.
move=> n nB; move:(BS_succ nB) => snB;rewrite (pc _ snB) /p (p1 _ snB).
rewrite (Y_false (@succ_nz n)) (cpred_pr2 nB).
congr (s _); rewrite restriction1_V //; first by fct_tac.
  rewrite segment_Bnat_order // ? pb.
  apply: Bint_S1.
by rewrite (segment_Bnat_order snB); apply: Bint_si.
Qed.

Lemma integer_induction0 h a: exists ! f,
  [/\ source f = Bnat, surjection f,
    Vf f \0 c = a &
    forall n, inc n Bnat -> Vf f (succ n) = h n (Vf f n)].
Proof.
exists (induction_defined0 h a); split.
  apply: (induction_defined_pr0).
move:(induction_defined_pr0 h a) => [sy sjy y0 ys] x [sx sjx x0 xs].
apply: function_exten4=>//; first by ue.
rewrite sy; apply: cardinal_c_induction; first by ue.
by move=> n nB eq; rewrite (xs _ nB) (ys _ nB) eq.
Qed.

Lemma integer_induction s a: exists ! f,
  [/\ source f = Bnat, surjection f, Vf f \0 c = a &
  forall n, inc n Bnat -> Vf f (succ n) = s (Vf f n)].
Proof.
set (h:= fun _ x:Set => s x).
move: (integer_induction0 h a) => //.
Qed.

Definition induction_term s a := Vf (induction_defined0 s a).

Lemma induction_term0 s a:
  induction_term s a \0 c = a.
Proof.
move: (induction_defined_pr0 s a)=> [sf sjf w0 ws].
rewrite /induction_term //.
Qed.

Lemma induction_terms s a n:
  inc n Bnat ->
  induction_term s a (succ n) = s n (induction_term s a n).
Proof.
move: (induction_defined_pr0 s a)=> [sf sjf w0 ws] nB.
rewrite /induction_term ws //.
Qed.

Theorem shepherd_principle f c: function f ->
  (forall x, inc x (target f) -> cardinal (inv_image_by_fun f (singleton x))=c)
  -> cardinal (source f) = (cardinal (target f)) *c c.
Proof.
move=> ff cc.
set (pa := Lg (target f) (fun z=> (inv_image_by_fun f (singleton z)))).
have up: (unionb pa = (source f)).
  set_extens x.
    rewrite /pa; move /setUb_P; bw; move => [y ytf]; bw.
    move /iim_fun_P => [u /set1_P -> Jg];Wtac.
  move => xsf; move: (Vf_target ff xsf)=> Wt.
  apply /setUb_P; exists (Vf f x); rewrite /pa; bw => //.
  by apply: iim_fun_set1_i.
have md: (mutually_disjoint pa).
  apply: mutually_disjoint_prop.
  rewrite/pa /inv_image_by_fun; bw=> i j y it jt; bw.
  move => sa sb.
  by rewrite (iim_fun_set1_hi ff sa) (iim_fun_set1_hi ff sb).
have fgp: (fgraph pa) by rewrite /pa; fprops.
move: (csum_pr pa); rewrite /card_sumb.
set f' := Lg _ _.
have ->: f' =cst_graph (domain pa) c.
  apply: Lg_exten; rewrite /pa; bw; move => x xtf /=; bw; apply: cc=>//.
rewrite csum_of_same.
have ->:c *c (domain pa) = (cardinal (target f)) *c c.
  rewrite cprodC /pa; bw.
  apply: cprod2_pr2; fprops; symmetry;apply: card_card; fprops.
move => <-.
rewrite -up; apply /card_eqP.
apply: equipotent_disjointU; fprops.
rewrite /disjointU_fam; split;fprops; bw.
move=> i id; bw; fprops.
Qed.

Definition factorial n :=
  card_prod (Lg (Bint n) succ).

Lemma factorial_succ n: inc n Bnat ->
  factorial (succ n) = (factorial n ) *c (succ n ).
Proof.
by move=> nB; rewrite (induction_on_prod succ nB).
Qed.

Lemma factorial0: factorial \0 c = \1 c.
Proof.
rewrite /factorial Bint_co00 cprod_trivial;fprops;bw.
Qed.

Lemma factorial1: factorial \1 c = \1 c.
Proof.
move: BS0 => zb.
rewrite - succ_zero factorial_succ // factorial0; aw; apply: CS_succ.
Qed.

Lemma factorial2: factorial \2 c = \2 c.
Proof.
rewrite - succ_one.
rewrite (factorial_succ BS1) factorial1 succ_one;aw; fprops.
Qed.

Lemma factorial_nz n: inc n Bnat -> factorial n <> \0 c.
Proof.
move: n;apply: cardinal_c_induction.
  rewrite factorial0; exact: card1_nz.
move=> m mB u; rewrite (factorial_succ mB).
apply: cprod2_nz =>//; apply: succ_nz.
Qed.

Lemma BS_factorial n: inc n Bnat -> inc (factorial n) Bnat.
Proof.
move=> nB.
apply: (cardinal_c_induction (r:=fun n=> inc (factorial n) Bnat)) =>//.
  rewrite factorial0; fprops.
move=> m mB u; rewrite (factorial_succ mB); fprops.
Qed.

Hint Resolve factorial_nz: fprops.

Lemma factorial_prop f: f \0 c = \1 c ->
  (forall n, inc n Bnat -> f (succ n) = (f n ) *c (succ n )) ->
  forall x, inc x Bnat -> f x = factorial x.
Proof.
move=> fz fp; apply: cardinal_c_induction.
  rewrite factorial0 //.
move=> m mB u; rewrite (factorial_succ mB) (fp _ mB) u // .
Qed.

Lemma factorial_induction n: inc n Bnat ->
factorial n = induction_term (fun a b => b *c (succ a )) \1 c n.
Proof.
move: n;apply: cardinal_c_induction.
  by rewrite factorial0 induction_term0.
by move=> m mB h; rewrite (factorial_succ mB) (induction_terms _ _ mB) h.
Qed.

Lemma quotient_of_factorials a b:
  inc a Bnat -> inc b Bnat -> b <=c a ->
  (factorial b ) %|c (factorial a ).
Proof.
move=> aB bB ab; rewrite -(cdiff_rpr ab).
move: (BS_diff b aB).
set (c := a -c b);rewrite csumC.
generalize c; apply: cardinal_c_induction.
  rewrite (bsum0r bB).
  apply: cdivides_itself.
   apply: BS_factorial =>//.
   apply: factorial_nz =>//.
move => n nB.
rewrite (csum_via_succ _ nB).
have p1: inc (b +c n) Bnat by fprops.
rewrite factorial_succ //;apply: cdivides_trans2; fprops.
Qed.

Lemma quotient_of_factorials1 a b:
  inc a Bnat -> inc b Bnat -> b <=c a ->
  (factorial (a -c b)) %|c (factorial a ).
Proof.
move=> aB bB leab; apply: (quotient_of_factorials aB).
  fprops.
apply: cdiff_le_symmetry=>//.
Qed.

Lemma factorial_monotone a b: inc b Bnat -> a <=c b ->
     factorial a <=c factorial b.
Proof.
move => bB leab.
move:(quotient_of_factorials bB (BS_le_int leab bB) leab) => [p1 p2 p3].
move:(cdiv_pr p1 p2); rewrite p3 (csum0r); last by fprops.
set q := _ %/c _.
case (equal_or_not q \0 c) => qz.
   by move:(factorial_nz bB); rewrite qz cprod0r.
move => ->; apply: (cprod_M1le (CS_Bnat p2) qz).
Qed.

Definition number_of_injections b a :=
  (factorial a ) %/c (factorial (a -c b)).

Lemma number_of_injections_pr a b:
  inc a Bnat -> inc b Bnat -> b <=c a ->
  (number_of_injections b a ) *c (factorial (a -c b)) = factorial a.
Proof.
rewrite/number_of_injections.
move=> aB bB leba; rewrite cprodC.
symmetry;apply: cdivides_pr3=>//.
by apply: quotient_of_factorials1.
Qed.

Lemma number_of_injections_int a b:
  inc a Bnat -> inc b Bnat ->
  inc (number_of_injections b a) Bnat.
Proof.
rewrite/number_of_injections => aB bB.
apply: (BS_quo (BS_factorial aB) (BS_factorial (BS_diff b aB))).
Qed.

Lemma number_of_injections_base a: inc a Bnat ->
  number_of_injections \0 c a = \1 c.
Proof.
rewrite /number_of_injections=> aB.
rewrite cdiff_n_0=> //.
apply: (cquo_itself (BS_factorial aB) (factorial_nz aB)).
Qed.

Lemma number_of_injections_rec a b:
  inc a Bnat -> inc b Bnat -> b <c a ->
  (number_of_injections b a ) *c (a -c b ) =
  number_of_injections (succ b) a.
Proof.
move=> aB bB ltab.
have leab: b <=c a by move: ltab => [le _].
move: (number_of_injections_pr aB bB leab).
set A:= number_of_injections b a.
have sB: inc (succ b) Bnat by fprops.
move /(card_le_succ_ltP _ bB): ltab => ltab.
rewrite - (number_of_injections_pr aB sB ltab).
set B:= number_of_injections (succ b) a.
have sb: inc (a -c (succ b)) Bnat by fprops.
rewrite (csucc_diff aB bB ltab).
rewrite factorial_succ; last by fprops.
set w := (succ (a -c (succ b))).
have wB: inc w Bnat by rewrite /w; fprops.
set D:= factorial (a -c (succ b)).
rewrite (cprodC D _) cprodA.
apply: cprod_simplifiable_right.
- rewrite /D; apply: BS_factorial =>//.
- apply: BS_prod.
    rewrite /A; apply: number_of_injections_int =>//.
    exact.
- rewrite /B; apply: number_of_injections_int =>//.
- by apply: factorial_nz.
Qed.

Definition injections E F :=
  Zo (functions E F)(injection).

Lemma number_of_injections_prop E F:
  finite_set F ->
  cardinal E <=c cardinal F ->
  cardinal (injections E F) =
    number_of_injections (cardinal E) (cardinal F).
Proof.
move=> fsF lce.
set (m:= cardinal F).
have fse: finite_set E by red; red in fsF; Bnat_tac.
move: lce.
have mB: inc m Bnat by apply /BnatP; rewrite /m; red in fsF.
pose s E := (cardinal E ) <=c m ->
   cardinal (injections E F) = number_of_injections (cardinal E) m.
apply: (finite_set_induction0 (s:=s)) =>//.
  rewrite /s cardinal_set0 number_of_injections_base //.
  move=> _.
  move: (empty_function_tg_function F); set f:= empty_function_tg F;
  move => [pa pb pc].
  have injf: injection f.
    split => //; rewrite /f pb => x y; case; case.
  have : (inc f (functions (source f) (target f))) by apply /fun_set_P.
  rewrite pb pc => aux.
  have ->: (injections emptyset F = singleton f).
    apply : set1_pr; first by apply:Zo_i.
    by move => z /Zo_S vs; rewrite (fun_set_small_source vs aux).
  by rewrite cardinal_set1.
clear fse E.
move=> E a sE naE; rewrite /s.
rewrite (card_succ_pr naE).
set (n := cardinal E).
move=> lem.
have snB: inc (succ n) Bnat by Bnat_tac.
have nB: inc n Bnat by apply: BS_nsucc; rewrite /n; fprops.
have ltnm: n <c m by apply /card_le_succ_ltP.
rewrite -(number_of_injections_rec mB nB ltnm).
have lenm: n <=c m by move: ltnm => [h _].
move: (sE lenm); rewrite -/n; move=> <-.
clear sE.
set (G2:= injections (E +s1 a) F).
set (G1:= injections E F).
set rf:=Lf (restriction ^~ E) G2 G1.
have <-: (source rf = G2) by rewrite /rf; aw.
have <-: (target rf = G1) by rewrite /rf; aw.
have ta: lf_axiom (restriction ^~ E) G2 G1.
  move=> t /Zo_P [] /fun_set_P [ft st tt] it.
  have sat: sub E (source t) by rewrite st; fprops.
  move: (restriction_prop (proj1 it) sat) => pp.
  apply : Zo_i; first by apply /fun_set_P; ue.
  move: pp => [pa pb pc].
  split => //; move=> x y; rewrite pb => xE yE.
  rewrite restriction_V // restriction_V //.
  move: it=> [_ it]; apply: it; apply: sat=>//.
have fr: function rf by apply: lf_function.
apply: shepherd_principle =>//.
move=> x.
set(K:= inv_image_by_fun rf (singleton x)).
rewrite lf_target; move /Zo_P => [] /fun_set_P [fx sxE txF] injx.
have fst: finite_set (target x) by red;rewrite txF;fprops.
move:(cardinal_complement_image injx fst).
set (C:= F -s (image_of_fun x)).
rewrite sxE txF -/n -/m -/C => <-.
set (val:= Lf (Vf ^~ a) K C).
have tav:(lf_axiom (Vf ^~ a) K C).
  move => z /iim_fun_P [u /set1_P uz h1]; move: (Vf_pr fr h1).
  move: (p1graph_source fr h1); rewrite {1} /rf; aw => tG2.
  rewrite /rf; aw.
  move: tG2 => /Zo_P [] /fun_set_P [fz sz tgz] injz.
  have asz: inc a (source z) by rewrite sz; fprops.
  move => xx.
  apply /setC_P; split; first by rewrite -tgz;Wtac.
  move /(Vf_image_P1 fx) => [y ysx].
  have Ez: sub E (source z) by rewrite sz; fprops.
  have yE: inc y E by ue.
  rewrite -uz xx; rewrite restriction_V // => sW; symmetry in sW.
  move: injz=> [ _ hi]; move: (hi _ _ (Ez _ yE) asz sW) => ya.
  by case: naE; rewrite - ya.
have fv: function val by rewrite /val; apply: lf_function.
have sv: (source val = K) by rewrite /val; aw.
have tv: (target val = C) by rewrite /val; aw.
apply /card_eqP; exists val; split => //; apply: lf_bijective =>//.
  move=> u v /iim_fun_P [u' /set1_P usx Jg1].
  move => /iim_fun_P [v' /set1_P vsx Jg2] sv1.
  have uG2:inc u G2 by move:(p1graph_source fr Jg1); rewrite /rf; aw.
  have vG2:inc v G2 by move:(p1graph_source fr Jg2); rewrite /rf; aw.
  move: (Vf_pr fr Jg1) (Vf_pr fr Jg2); rewrite /rf lf_V // lf_V //.
  move: uG2 => /Zo_P [] /fun_set_P [fu su tu] inju.
  move: vG2 => /Zo_P [] /fun_set_P [fvv svv tvv] injv sr1 sr2.
  apply: function_exten=>//; try ue.
  move=> t; rewrite su; case /setU1_P; last by move=> ->.
  move=> tE.
  transitivity (Vf x t).
    rewrite - usx sr1 restriction_V //; rewrite su; fprops.
  rewrite - vsx sr2 restriction_V //; rewrite svv; fprops.
move=> y / setC_P [yF nyi].
have nasc: ~ (inc a (source x)) by ue.
set (f:= extension x a y).
have ff: function f by rewrite /f; apply: extension_f=>//.
have sf: source f = E +s1 a by rewrite /f /extension; aw; ue.
have tf: target f = F.
by rewrite /f /extension; aw; rewrite txF; apply: setU1_eq.
have injf: injection f.
  split =>//; move=> u v;rewrite sf /f;case /setU1_P => xsf; case /setU1_P=>ysf.
  - rewrite !extension_Vf_in //; try ue; move: injx => [_ injx];apply: injx; ue.
  - rewrite - sxE in xsf.
    rewrite ysf extension_Vf_out // extension_Vf_in //.
    move=> eq; rewrite -eq in nyi; case: nyi.
    apply /(Vf_image_P1 fx); ex_tac; apply: W_pr3 =>//.
  - rewrite - sxE in ysf.
    rewrite xsf extension_Vf_out // extension_Vf_in //.
    move=> eq; rewrite eq in nyi; case: nyi.
    apply /(Vf_image_P1 fx);ex_tac; apply: W_pr3 =>//.
  - by rewrite xsf ysf.
have rFE:(restriction f E = x).
  have se: sub E (source f) by rewrite sf; fprops.
  move: (restriction_prop ff se) => [pa pb pc].
  apply: function_exten=>//; rewrite ? pb //.
    by rewrite pc tf txF.
    move=> u uE /=; rewrite restriction_V // /f extension_Vf_in//; ue.
have fG2: inc f G2.
  rewrite /G2/injections; apply: Zo_i=>//; apply /fun_set_P;split => //.
have fi:inc f (inv_image_by_fun rf (singleton x)).
  apply /iim_fun_P;exists x;fprops.
  have <-: (Vf rf f = x) by rewrite /rf lf_V//.
  apply: Vf_pr3=>//; rewrite /rf;aw.
ex_tac.
by rewrite /f extension_Vf_out.
Qed.

Lemma number_of_permutations E: finite_set E ->
  cardinal (permutations E) = (factorial (cardinal E)).
Proof.
move=> fsE.
have ->: (permutations E = injections E E).
  rewrite /permutations/injections.
  apply: Zo_exten1=> x; move /fun_set_P => [pa pb pc]; split.
     by case.
  apply: bijective_if_same_finite_c_inj =>//; [ rewrite pb pc // | ue ].
have aux: (cardinal E) <=c (cardinal E) by fprops.
rewrite (number_of_injections_prop fsE aux).
have cE: inc (cardinal E) Bnat by fprops.
rewrite /number_of_injections cdiff_n_n // factorial0 cquo_one //.
by apply: BS_factorial.
Qed.

Definition partition_with_pi_elements p E f :=
  [/\ domain f = domain p,
  (forall i, inc i (domain p) -> cardinal (Vg f i) = Vg p i) &
    partition_w_fam f E].

Definition partitions_pi p E :=
  Zo (gfunctions (domain p) (powerset E)) (partition_with_pi_elements p E).

Lemma partitions_piP p E f:
  inc f (partitions_pi p E) <-> partition_with_pi_elements p E f.
Proof.
split; first by case /Zo_P.
move=> h; apply: Zo_i =>//.
move: h => [p2 _ [p5 _ p7]].
set (g := triple (domain p) (powerset E) f).
have ->: (domain p = source g) by rewrite /g -p2; aw.
have ->: (powerset E = target g) by rewrite /g; aw.
have ->: (f = graph g) by rewrite /g; aw.
apply: gfun_set_i; apply: function_pr =>//.
move=> t. move/(range_gP p5) => [x xdf ->]; apply /setP_P.
move => y; rewrite -p7 => hh; union_tac.
Qed.

Lemma fif_cardinal i p:
  finite_int_fam p -> inc i (domain p) -> cardinalp (Vg p i).
Proof. by move=> [fgp alip fdp]; fprops. Qed.

Lemma pip_prop0 p E f: partition_with_pi_elements p E f ->
  forall i, inc i (domain f) -> sub (Vg f i) E.
Proof.
move=> [df cVg [fgf duj ue]].
move=>i idp t tW; rewrite -ue; union_tac.
Qed.

Lemma number_of_partitions1 p E:
  finite_int_fam p -> card_sum p = cardinal E ->
  nonempty (partitions_pi p E).
Proof.
move=> fif.
move /card_eqP => [f [[bf sjf] sf tg]].
pose k i := (Vg p i ) *s1 i.
have sx: forall i, inc i (domain p) ->sub (k i) (source f).
  move=> i idp t tk; rewrite sf; apply /setUb_P1; ex_tac.
set g:= Lg (domain p) (fun i => image_by_fun f (k i)).
exists g; apply /partitions_piP; red.
split => //.
    rewrite /g; bw.
  move=> i idp; rewrite /g /k;bw.
  rewrite -{2} (card_card (fif_cardinal fif idp)).
  apply /card_eqP;eqsym;eqtrans ((Vg p i) *s1 i).
  apply: equipotent_restriction1 =>//; apply: sx =>//.
have ff: function f by fct_tac.
split => //.
    rewrite /g;fprops.
  rewrite /g.
  apply: mutually_disjoint_prop; bw.
  move=> i j y idp jdp; bw.
  move: (sx _ idp)(sx _ jdp)=> p1 p2.
  move => /(Vf_image_P ff (sx _ idp)) [u uki Wu].
  move => /(Vf_image_P ff (sx _ jdp)) [v vkj Wv].
  have uv: u = v.
     move: bf => [_ injf].
     rewrite Wv in Wu; apply: injf =>//;[apply:(p1 _ uki) | apply: (p2 _ vkj)].
  move: uki vkj; rewrite uv /k.
  by move /indexed_P => [_ _ <-] /indexed_P [_ _ <-].
rewrite /g -tg.
set_extens x.
  move /setUb_P; bw; move=> [y yd]; move: (sx _ yd) => aux; bw.
  move=> /(Vf_image_P ff aux) [u uk ->]; Wtac.
move=> xtf; move: ((proj2 sjf) _ xtf)=> [y ysf Wy].
move: ysf; rewrite sf; move /disjointU_P=> [pa pb pc].
apply /setUb_P1;ex_tac; apply /(Vf_image_P ff (sx _ pa)).
by rewrite /k;exists y => //; apply /indexed_P.
Qed.

Definition partitions_aux f g:=
  Lg (domain f) (fun i => image_by_fun g (Vg f i)).

Lemma number_of_partitions3 p E f g:
  partition_with_pi_elements p E f -> inc g (permutations E) ->
  inc (partitions_aux f g) (partitions_pi p E).
Proof.
move=> pip gp.
apply /partitions_piP.
move: gp => /Zo_P [] /fun_set_P [fg sg tg [ig sjg]].
have Ha:forall u, inc u (domain f) -> sub (Vg f u) (source g).
  rewrite sg; apply: (pip_prop0 pip).
move: pip => [df cVg [fgf duj ue]].
rewrite/partitions_aux.
red;bw; split => //.
  rewrite df;move=> i idp; bw; rewrite - (cVg _ idp) ; symmetry.
  apply /card_eqP.
  apply: equipotent_restriction1 =>//; apply: Ha =>//; ue.
split;fprops.
  apply: mutually_disjoint_prop=>//.
  bw; move=> i j y idp jdp.
  move: (Ha _ idp) (Ha _ jdp)=> s1 s2.
  bw; move=> /(Vf_image_P fg s1) [u ui Wu] /(Vf_image_P fg s2) [v vi Wv].
  have uv: u = v.
    move: ig => [_ ig]; rewrite Wv in Wu;apply: ig; fprops.
  red in duj; case: (duj _ _ idp jdp)=> // ns.
  rewrite /Vf in ui vi; rewrite -uv in vi.
  red in ns; empty_tac1 u.
rewrite -tg;set_extens x.
  move /setUb_P1 => [y ydp].
  move /(Vf_image_P fg (Ha _ ydp)) => [u ua ->]; Wtac; exact: (Ha _ ydp).
move=> xtg; move: ((proj2 sjg) _ xtg)=> [y ysf Wy].
move: ysf; rewrite sg -ue;move=> /setUb_P [t tf etc].
apply /setUb_P1; ex_tac; apply /(Vf_image_P fg (Ha _ tf)); ex_tac.
Qed.

Lemma number_of_partitions4 p E f:
  finite_int_fam p -> card_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  surjection (Lf (partitions_aux f)
    (permutations E) (partitions_pi p E)).
Proof.
move=> fip spE [df cVg pfa];move:(pfa)=> [fgf duj ue].
set phi:=Lf _ _ _.
apply: lf_surjective; first by move=> g; apply: number_of_partitions3 =>//.
have Ha:finite_set E by red;rewrite - spE; apply /BnatP /finite_sum_finite.
move=> y /partitions_piP [dy cVy [fgy dujy uey]].
pose ha i := equipotent_ex (Vg f i) (Vg y i).
have hap: forall i, inc i (domain p) ->
    bijection_prop (ha i) (Vg f i) (Vg y i).
   move=> i idp; rewrite /ha; apply: equipotent_ex_pr.
   by apply /card_eqP; rewrite (cVg _ idp) (cVy _ idp).
pose h i := Lf (Vf (ha i)) (Vg f i) E.
have ta1:forall i, inc i (domain p) -> lf_axiom (Vf (ha i)) (Vg f i) E.
  move=> i idp z zW.
  move: (hap _ idp)=> [[[fh _] _] sh th].
  rewrite - sh in zW;move: (Vf_target fh zW); rewrite th -uey.
  move=> h1; apply /setUb_P; exists i => //; ue.
have fp1:(forall i, inc i (domain f) -> function_prop (h i) (Vg f i) E).
  rewrite df /h=> i idp; split; aw; apply: lf_function; apply: ta1 =>//.
rewrite -df in hap.
move: (extension_partition1 pfa fp1).
set g := common_ext _ _ _; move=> [[fg sg tg] extg].
have injg: injection g.
  split=> //; move=> u v.
  rewrite sg -ue; move=> /setUb_P [u' u'd Vu'] /setUb_P [v' v'd Vv'].
  have pu : Vf g u = Vf (ha u') u.
    move: (extg _ u'd) => [p1 p2 ->] //;rewrite /h; aw; apply: ta1; ue.
  have pv: Vf g v = Vf (ha v') v.
    move: (extg _ v'd)=> [p1 p2 -> ] //; rewrite /h; aw; apply: ta1; ue.
  move=> eq; suff:u' = v'.
    move: (hap _ u'd) => [[[_ ih] _] sa _] aux.
    by rewrite sa in ih; apply: ih =>//; rewrite - ? pu ? aux // eq pv.
  case: (duj _ _ u'd v'd) =>// dj.
  have Wu: (inc (Vf g u) (Vg y u')).
    rewrite pu; move: (hap _ u'd) => [[fh _] sa <-]; Wtac; fct_tac.
  have Wv: (inc (Vf g v) (Vg y v')).
    rewrite pv; move: (hap _ v'd) => [[fh _] sa <-]; Wtac; fct_tac.
  red in dujy; rewrite dy -df in dujy.
  case: (dujy _ _ u'd v'd) =>//.
  move=> h1; rewrite eq in Wu; empty_tac1 (Vf g v).
have bx: (bijection g).
  apply: bijective_if_same_finite_c_inj=>//; [ by rewrite sg tg | ue].
have pg: inc g (permutations E) by apply: Zo_i=>//; apply /fun_set_P.
ex_tac.
symmetry.
rewrite /partitions_aux; apply: fgraph_exten =>//; [ fprops | bw; ue|].
bw; move=> x xdf; bw.
move: (hap _ xdf) => [bha sha tha].
move: (fp1 _ xdf) (extg _ xdf) => [fh sh th] [p2a _ p2c].
have p3 : forall i, inc i (Vg f x) -> Vf g i = Vf (ha x) i.
  move=> i ins; rewrite (p2c _ ins).
  by rewrite /h; aw; apply: ta1 =>//; ue.
rewrite -tha.
set_extens u; bw.
   move /(Vf_image_P fg p2a)=> [i ins ->]; rewrite (p3 _ ins); Wtac;fct_tac.
move: bha => [iha sjha] ut.
move: ((proj2 sjha) _ ut)=> [v vs Wv].
rewrite sha in vs; rewrite - Wv - (p3 _ vs); apply /(Vf_image_P fg p2a).
by ex_tac; apply: Vf_pr3 =>//; apply: p2a.
Qed.

Lemma number_of_partitions5P p E f g h:
  finite_int_fam p -> card_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  inc h (permutations E) -> inc g (permutations E) ->
( (partitions_aux f g = partitions_aux f h ) <->
  (forall i, inc i (domain p) ->
      image_by_fun ( (inverse_fun h ) \co g) (Vg f i) = (Vg f i ))).
Proof.
move=> fip spE pip; move: (pip_prop0 pip)=> Ht.
move: pip => [df cVg [fgf duj ue]].
move => /Zo_P [] /fun_set_P [fh sh th] bh.
move => /Zo_P [] /fun_set_P [fg sg tg] bg.
have fih: function (inverse_fun h) by apply: bijective_inv_f.
have cih: (inverse_fun h) \coP g by split => //; aw; ue.
have fcih : function ((inverse_fun h) \co g) by fct_tac.
rewrite -df; split.
  move=> eq i idp; move: (f_equal (Vg ^~ i) eq);rewrite /partitions_aux; bw.
  move=> eql;rewrite /image_by_fun/inverse_fun/compose; aw.
  set_extens x.
    move /dirim_P => [y yW /compg_pP [z pa /igraph_pP pb]].
    have : inc z (image_by_fun g (Vg f i)) by apply /dirim_P; ex_tac.
    rewrite eql; move /dirim_P => [x' x'Vf Jg2].
    move: bh => [injh _]; rewrite (injective_pr3 injh pb Jg2) //.
  move=> xW.
  have xsh: inc x (source h) by rewrite sh; apply: (Ht _ idp).
  have : (inc (Vf h x) (image_by_fun h (Vg f i))).
     apply /dirim_P; ex_tac; Wtac.
  rewrite -eql; move /dirim_P => [x' x'Vf Jg].
  apply /dirim_P; ex_tac; apply /compg_pP; ex_tac; apply /igraph_pP;Wtac.
move=> aux; apply: Lg_exten.
move=> i xdp; move: (aux _ xdp) => aux'.
set_extens x.
  move /(dirim_P) => [y yVf Jg].
  have xt:inc x (target h)
     by rewrite th -tg ;apply: (p2graph_target fg Jg).
  move: (p1graph_source fg Jg) =>ys.
  move: bh=> [_ sjh]; move: ((proj2 sjh) _ xt)=> [z zs Wz].
  have p2: inc (J z x) (graph h) by rewrite -Wz;apply: Vf_pr3 =>//.
  apply /dirim_P; ex_tac; rewrite -(aux _ xdp).
  apply /dirim_P; exists y => //; rewrite corresp_g; apply /compg_pP.
  by exists x=> //; rewrite /inverse_fun; aw; apply /igraph_pP.
rewrite -{1} aux'/image_by_fun/compose /inverse_fun.
rewrite !corresp_g; move /(dirim_P)=> [u] /(dirim_P) [v Jg].
move /compg_pP =>[w pa /igraph_pP pb] pc.
apply /dirim_P; ex_tac.
rewrite - (fgraph_pr _ pb pc); fprops.
Qed.

Lemma number_of_partitions6 p E f h:
  finite_int_fam p -> card_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  inc h (permutations E) ->
  lf_axiom (fun g=> Lg (domain p)(fun i=> (restriction2
    ((inverse_fun h ) \co g)
    (Vg f i) (Vg f i))))
  (Zo (permutations E)
    (fun g => (partitions_aux f g = partitions_aux f h)))
  (productb (Lg (domain p)(fun i=> (permutations (Vg f i))))).
Proof.
move=> fip spE pip hp g; move: (pip_prop0 pip)=> Ht.
move: (pip) => [df cVg [fgf duj ue]].
move /Zo_P => [gp eql]; apply /setXb_P; fprops;split;fprops; bw.
move=> i idp; bw.
move: eql; move /(number_of_partitions5P fip spE pip hp gp) => eql.
move: (eql _ idp) => ic; clear eql.
move: hp gp => /Zo_P [] /fun_set_P [fh sh th] bh.
move=> /Zo_P [] /fun_set_P [fg sg tg] bg.
have fih: function (inverse_fun h) by apply: bijective_inv_f.
have cih: (inverse_fun h) \coP g by split => //; aw; ue.
have fcih : function ((inverse_fun h) \co g) by fct_tac.
set k:= restriction2 _ _ _.
have sk: source k = Vg f i by rewrite /k/restriction2; aw.
have tk: target k = Vg f i by rewrite /k/restriction2; aw.
rewrite df in Ht; move: (Ht _ idp) => Ht1.
have ra: (restriction2_axioms (compose (inverse_fun h) g) (Vg f i) (Vg f i)).
   red; aw; split => //; ue.
have fk: (function k) by rewrite /k; apply: (proj31(restriction2_prop ra)).
apply: Zo_i; first by apply /fun_set_P;split => //.
apply: bijective_if_same_finite_c_inj.
    by rewrite sk tk.
  red;rewrite sk; move: fip=> [hp _ ]; move: (hp _ idp).
  by move: pip => [_ pip _];rewrite (pip _ idp); fprops.
split=>// x y; rewrite sk => xsk ysk.
rewrite /k restriction2_V //restriction2_V //.
move: (Ht1 _ xsk) (Ht1 _ ysk); rewrite - sg => xsg ysg.
aw;move => eq.
move: bg=> [[_ ig] _ ]; apply: ig =>//.
move: (inverse_bij_fb bh) => [[_ iih] _ ].
move:iih; aw; apply =>//; try (rewrite th -tg; Wtac).
Qed.

Lemma number_of_partitions7 p E f h:
  finite_int_fam p -> card_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  inc h (permutations E) ->
  bijection (Lf (fun g=> Lg (domain p)(fun i=> (restriction2
    ((inverse_fun h ) \co g)
    (Vg f i) (Vg f i))))
  (Zo (permutations E)
    (fun g => (partitions_aux f g = partitions_aux f h)))
  (productb (Lg (domain p)(fun i=> (permutations (Vg f i)))))).
Proof.
move=> fip spE pip hp; move: (pip_prop0 pip)=> sWE.
move: (pip) => [df cVg [fgf duj ue]].
rewrite df in sWE.
set ww:=Lf _ _ _.
move: (number_of_partitions6 fip spE pip hp) => ta.
move:(hp) => /Zo_P [] /fun_set_P [fh sh th] bh.
have bih: (bijection (inverse_fun h)) by apply: inverse_bij_fb.
have fw: function ww by rewrite /ww; apply: lf_function.
move: (pip) => [_ _ pfa].
have sw: surjection ww.
  split => //.
  rewrite /ww lf_source lf_target => y.
  set xxx := Lg _ _; have fgg: fgraph xxx by rewrite /xxx; fprops.
  move /setXb_P; rewrite /xxx; clear fgg xxx; bw.
  move=> [fgy dy yp].
  set (ha := fun i=> Vg y i).
  have yp': (forall i, inc i (domain p) ->
    (bijection_prop (ha i) (Vg f i) (Vg f i))).
    move=> i idp;move: (yp _ idp); bw.
     move => /Zo_P [] /fun_set_P [pa pb pc]; split => //.
  pose hb i := Lf (Vf (ha i)) (Vg f i) E.
  have ta1: (forall i, inc i (domain p) -> lf_axiom (Vf (ha i)) (Vg f i) E).
    move=> i idp z zW; move: (yp' _ idp)=> [bha sha tha].
    apply: (sWE _ idp); rewrite -tha;Wtac; fct_tac.
  have Hw:forall i, inc i (domain f) -> function_prop (hb i) (Vg f i) E.
    rewrite df; move => i ip; rewrite /hb /function_prop lf_source lf_target.
    split => //; apply: lf_function;apply: ta1 =>//.
  move: (extension_partition1 pfa Hw).
  set g := common_ext _ _ _; move => [[fg sg tg] alag].
  have ijg: injection g.
    split=>// u v; rewrite sg => uE vE.
    move: uE vE;rewrite -ue; move=> /setUb_P [a adf ua] /setUb_P [b bdf vb].
    move: (alag _ adf)(alag _ bdf) => [p1 p2 p3] [q1 q2 q3].
    have ap: inc a (domain p) by ue.
    have bp: inc b (domain p) by ue.
    rewrite (p3 _ ua)(q3 _ vb).
    move : (ta1 _ ap) (ta1 _ bp) => ta2 ta3.
    rewrite /hb (lf_V ta2 ua) (lf_V ta3 vb).
    move: (yp' _ ap) (yp' _ bp)=> [[[_ iha] xx] sha tha] [yy shb thb].
    case: (duj _ _ adf bdf).
      move=> ab; rewrite -ab in vb; rewrite -ab.
      apply: iha; rewrite sha //.
    move=> h1 h2; empty_tac1 (Vf (ha a) u).
     rewrite /Vf in tha;rewrite -tha; Wtac; fct_tac.
     rewrite /Vf in thb;rewrite h2 -thb; Wtac; fct_tac.
  have bg: (bijection g).
    apply: bijective_if_same_finite_c_inj; last by exact.
       rewrite sg tg //.
    rewrite sg; apply /BnatP; rewrite - spE; apply: finite_sum_finite =>//.
  have pa:forall i v, inc i(domain p) -> inc v (Vg f i)-> Vf g v = Vf (ha i) v.
    rewrite -df;move=> i v idp; move: (alag _ idp).
    rewrite /agrees_on; move => [s1 s2 aux].
    move=> vW; move: (aux _ vW); rewrite /hb lf_V;
       [done | apply: ta1;ue| done ].
  have pb:forall i v, inc i (domain p)-> inc v (Vg f i) -> inc (Vf g v)(Vg f i).
    move=> i v ip iv; rewrite (pa _ _ ip iv).
    move: (yp' _ ip) => [bha sha tha]; Wtac; fct_tac.
  have chg: (h \coP g) by split => //;ue.
  have fhg: function (h \co g) by fct_tac.
  have bhg: (bijection (h \co g)) by apply: compose_fb.
  set (t:= h \co g).
  have pt: inc t (permutations E).
    apply: Zo_i => //; apply /fun_set_P; red;rewrite /t; aw; split => //.
  set z:=Zo _ _.
  have xz:inc t z.
    apply: Zo_i => //.
    rewrite /partitions_aux df; apply: Lg_exten.
    move=> i idp /=; set_extens u; aw.
      move /dirim_P => [a ai]; rewrite /t /compose; aw.
      move /compg_pP => [b Jg1 Jg2]; apply /dirim_P; ex_tac.
      by move: (Vf_pr fg Jg1) => ->; apply: pb.
    move=> /dirim_P [a asVf Jg].
    have atg: inc a (target g) by rewrite tg; apply: (sWE _ idp).
    move: (bg) => [_ sjg]; move: ((proj2 sjg) _ atg) => [b bsg Wb].
    move: (bsg); rewrite sg; rewrite -ue; move /setUb_P => [j jd bW].
    apply /dirim_P.
    rewrite -df in idp; case: (duj _ _ idp jd).
      move=> eq; rewrite -eq in bW; ex_tac.
      rewrite /t /compose; aw; apply /compg_pP; ex_tac; rewrite -Wb; Wtac.
    move=> di; empty_tac1 a.
    rewrite -df in pb; rewrite -Wb;apply: (pb _ _ jd bW).
  ex_tac; rewrite (lf_V ta xz).
  have ->: ( (inverse_fun h) \co t = g).
   rewrite /t (compfA (composable_inv_f bh) chg).
   rewrite bij_left_inverse // sh -tg compf_id_l //.
  apply: fgraph_exten;bw; fprops.
  move=> x xdp; bw.
  move: (sWE _ xdp)=> Wf.
  have ra: (restriction2_axioms g (Vg f x) (Vg f x)).
   have ssg: sub (Vg f x) (source g) by rewrite sg.
   have stg: sub (Vg f x) (target g) by rewrite tg.
   split => //; move=> u /(Vf_image_P fg ssg) [v vW ->]; apply: (pb _ _ xdp vW).
  move : (yp' _ xdp); rewrite /ha; move=> [bha sha tha].
  bw; apply: function_exten.
  - by apply: (proj31 (restriction2_prop ra)).
  - fct_tac.
  - by rewrite /restriction2 sha corresp_s.
  - by rewrite /restriction2 tha corresp_t.
  - rewrite /restriction2; aw; move=> u uW /=; rewrite restriction2_V //.
    by rewrite (pa _ _ xdp uW).
split=>//; split =>//.
rewrite /ww lf_source=> x y xS yS; rewrite (lf_V ta xS) (lf_V ta yS).
move: xS yS => /Zo_P [xs eq1] /Zo_P [ys eq2].
move: eq1 => /(number_of_partitions5P fip spE pip hp xs) => eq1.
move: eq2 => /(number_of_partitions5P fip spE pip hp ys) => eq2.
move: eq1 eq2.
set xi:= _ \co x; set yi:= _ \co y => eq1 eq2.
have shi: (source (inverse_fun h)= E) by aw.
have thi: (target (inverse_fun h)= E) by aw.
move: xs ys => /Zo_P [] /fun_set_P [fx sx tx] bx
     /Zo_P [] /fun_set_P [fy sy ty] bjy eq.
have Hx: (inverse_fun h) \coP x by split => //;[ fct_tac | ue].
have Hy: (inverse_fun h) \coP y by split => //;[ fct_tac | ue].
suff: xi = yi.
  rewrite /xi /yi;move => eqi; move: (f_equal (compose h) eqi).
  move: (composable_f_inv bh) => co.
  rewrite (compfA co Hx) (compfA co Hy) (bij_right_inverse bh).
  by rewrite th -{1} tx -ty (compf_id_l fx) (compf_id_l fy).
have fxi: function xi by rewrite/xi; apply: compf_f=>//.
have fyi: function yi by rewrite/xi; apply: compf_f=>//.
have sxi: source xi = E by rewrite /xi compf_s.
have syi: source yi = E by rewrite /yi compf_s.
have txi: target xi = E by rewrite /xi compf_t.
have tyi: target yi = E by rewrite /yi compf_t.
apply: (function_exten fxi fyi); [ by rewrite syi | by rewrite tyi| ].
rewrite sxi -ue;move=> u; move /setUb_P; rewrite df; move=> [i ip iW].
move: (f_equal (Vg ^~i) eq); bw => eq3.
have ra:restriction2_axioms xi (Vg f i) (Vg f i).
  split => //; last (by rewrite eq1; fprops);
  rewrite ?sxi ?txi; apply: (sWE _ ip).
have rb:restriction2_axioms yi (Vg f i) (Vg f i).
  split => //; last (by rewrite eq2; fprops);
    rewrite ? syi ? tyi; apply: (sWE _ ip).
move: (f_equal (Vf ^~u) eq3);rewrite restriction2_V // restriction2_V //.
Qed.

Theorem number_of_partitions p E:
  finite_int_fam p -> card_sum p = cardinal E ->
  let num:= factorial (cardinal E) in
    let den := card_prod (Lg (domain p) (fun z => factorial (Vg p z)))
      in (
        [/\ num = cardinal (partitions_pi p E) *c den ,
        inc num Bnat, inc den Bnat, den <> card_zero &
        finite_set (partitions_pi p E)]).
Proof.
move => fip spe num den.
move: (number_of_partitions1 fip spe)=> [h hp].
have Hb: finite_set E.
  by red; rewrite - spe; apply /BnatP; apply: finite_sum_finite=> //.
have numB: inc num Bnat by rewrite /num; apply: BS_factorial; apply /BnatP; aw.
have ndenB: inc den Bnat.
  move: fip=> [p2 p3].
  rewrite /den;apply: finite_product_finite =>//.
  by red; bw;split => //; red; bw => i idp; bw; apply: BS_factorial; apply: p2.
have nd:den <> \0 c.
  apply /cprod_nzP; red;bw.
  move: fip=> [p2 p3].
  red;move=> i idp; bw; apply: factorial_nz; apply: p2=>//.
rewrite /finite_set.
set aux:= cardinal _.
suff: num = aux *c den.
  move => eql; split => //.
  rewrite eql in numB.
  have ca: cardinalp aux by rewrite /aux; fprops.
  apply /BnatP; apply: (Bnat_in_product ca nd numB).
move: hp => /Zo_P [hfpp pip].
move:(number_of_partitions4 fip spe pip).
set phi:= Lf _ _ _; move=> sjphi.
have caux:(forall w, bijection w -> cardinal (source w) = cardinal (target w)).
  by move=> w bw; apply /card_eqP; exists w; split => //.
suff phip: forall x, inc x (target phi) ->
    cardinal (inv_image_by_fun phi (singleton x)) = den.
  move: sjphi=> [fphi _].
  move:(shepherd_principle fphi phip).
  rewrite /phi lf_source lf_target number_of_permutations //.
move=> x xt.
move:((proj2 sjphi) _ xt) => [y ys yw].
move: ys; rewrite {1}/ phi; aw => yp.
move: (number_of_partitions7 fip spe pip yp) => baux.
move: (caux _ baux); rewrite lf_source lf_target; clear baux.
set d:= cardinal (productb _).
have ->: d = den.
  apply/card_eqP; apply: equipotent_setXb; split;fprops; bw.
  move=> i idp; bw.
  move: pip fip=>[p1 p2 [p3 _ _]] [q2 q3].
  apply /card_eqP; rewrite number_of_permutations.
    rewrite (p2 _ idp).
    set (t := (factorial (Vg p i))).
    have ct: cardinalp t by move: (BS_factorial (q2 _ idp)); fprops.
    by symmetry; apply: card_card.
  red; rewrite p2 //; apply /BnatP; apply: q2 =>//.
move => <-; set z := Zo _ _.
have Ha:lf_axiom (fun g =>
     (partitions_aux h g)) (permutations E) (partitions_pi p E).
  move => g gp; apply: number_of_partitions3 =>//.
apply: f_equal.
have fphi: function phi by fct_tac.
set_extens t.
  move /(iim_fun_set1_P _ fphi) => []; rewrite /phi lf_source => ta; aw => tb.
  apply: Zo_i => //; rewrite - tb -yw /phi; aw.
move /Zo_P => [pa pb].
apply: (iim_fun_set1_i fphi); rewrite /phi; aw.
by rewrite -yw /phi; aw.
Qed.

Theorem number_of_partitions_bis p E:
  finite_int_fam p -> card_sum p = cardinal E ->
  cardinal (partitions_pi p E) =
  (factorial (cardinal E)) %/c
           (card_prodb (domain p) (fun z => factorial (Vg p z))).
Proof.
move=> h1 h2.
move: (number_of_partitions h1 h2); simpl.
set (x1:= cardinal (partitions_pi p E)).
set x2:= card_prod _.
move=> [p1 p2 p3 p4] /BnatP p5.
rewrite p1 cprodC; symmetry; apply: cdivides_pr4 =>//.
Qed.

Lemma number_of_partitions_p2 E m p:
inc m Bnat -> inc p Bnat -> cardinal E = (m +c p ) ->
let num := factorial (m +c p) in
let den := (factorial m ) *c (factorial p ) in
let x := cardinal (partitions_pi (variantLc m p) E) in
   [/\ inc x Bnat, num = x *c den,
      inc num Bnat, inc den Bnat & den <> \0 c].
Proof.
move=> mB pB cE num den.
set P:= variantLc m p.
move=> x.
have h1: finite_int_fam P.
  rewrite /P;split;fprops.
  by red; bw; move=> i it; try_lvariant it; rewrite - inc_Bnat.
  bw;apply: set2_finite.
have p2: card_sum P = cardinal E.
  symmetry;rewrite cE /card_sum2/card_sum; fprops.
move: (number_of_partitions h1 p2); simpl.
set y:= card_prod _.
have -> : den = y.
  rewrite /den/card_prod2/y/P; bw.
  apply: f_equal; apply: fgraph_exten; fprops; bw.
  move=> xx xtp /=; try_lvariant xtp; fprops.
rewrite cE; move=> [r1 r2 r3 r4 r5];split;fprops.
Qed.

Binomial coefficient

Definition binom n m :=
  Vg (induction_term
      (fun _ T: Set => Lg Bnat (fun z => variant \0 c \1 c
          (Vg T z +c Vg T (cpred z)) z))
       (Lg Bnat (variant \0 c \1 c \0 c))
       n) m.

Lemma binom00: binom \0 c \0 c = \1 c.
Proof.
by rewrite /binom induction_term0 /variant; bw; [ Ytac0 | fprops ].
Qed.

Lemma binom0Sm m: inc m Bnat ->
  binom \0 c (succ m) = \0 c.
Proof.
move=> mBnat.
rewrite /binom /variant induction_term0; bw; last by fprops.
have snz: succ m <> \0 c by apply: succ_nz.
by Ytac0.
Qed.

Lemma binomSn0 n: inc n Bnat-> binom (succ n) \0 c = \1 c.
Proof.
move=> nB; rewrite /binom /variant induction_terms //.
bw; [by Ytac0 | fprops]; fprops.
Qed.

Lemma binomSnSm n m: inc n Bnat-> inc m Bnat ->
  binom (succ n) (succ m) = (binom n (succ m)) +c (binom n m ).
Proof.
move=> nB mB.
rewrite /binom /variant induction_terms //.
set T := induction_term _ _.
have snz: succ m <> \0 c by apply: succ_nz.
bw; [Ytac0; rewrite cpred_pr1 //; fprops | fprops ].
Qed.

Lemma BS_binom n m: inc n Bnat -> inc m Bnat ->
  inc (binom n m) Bnat.
Proof.
move=> nB; move: n nB m.
apply: cardinal_c_induction.
  apply: cardinal_c_induction.
      rewrite binom00=>//; fprops.
    move => n nB _; rewrite binom0Sm=>//; fprops.
move => n nB hrec; apply: cardinal_c_induction.
  rewrite binomSn0=>//; fprops.
move => p pB bB.
rewrite binomSnSm=>//; fprops.
Qed.

Lemma binom_alt_pr n m: inc n Bnat -> inc m Bnat ->
  (binom n m ) *c (factorial m ) *c (factorial (n -c m)) =
  Yo (m <=c n) (factorial n) \0 c.
Proof.
move: n m.
pose Bi n m := (binom n m ) *c
     (factorial m *c (factorial (n -c m))).
have ba4: forall n m, inc n Bnat -> inc m Bnat -> Bi (succ n) (succ m)=
    ((Bi n (succ m)) *c (Yo (n <=c m) \1 c (n -c m)))
   +c (Bi n m *c succ m ).
  move=> n m nB mB.
  set (x:= Bi n m); set (y:= Bi n (succ m)).
  rewrite /Bi binomSnSm //.
  rewrite cdiff_pr6 =>//.
  set aux := (factorial (succ m)) *c (factorial (n -c m)).
  rewrite cprod_sumDr.
  set A:= (binom n (succ m)) *c aux.
  set (AA:= y *c (Yo (n <=c m) \1 c (n -c m))).
  suff: A = AA.
    move=> ->; rewrite /x /Bi - cprodA; congr (_ +c (_ *c _)).
    rewrite (cprodC (factorial m) _) - cprodA -(factorial_succ mB).
    rewrite cprodC//.
  rewrite /A /AA /y /Bi; rewrite /aux - ! cprodA; congr (_ *c (_ *c _)).
  have nsmB: inc (n -c (succ m)) Bnat by fprops.
  case: (p_or_not_p (n <=c m)) => le.
    have cf: cardinalp (factorial (n -c (succ m))).
      apply: CS_Bnat;apply: (BS_factorial nsmB).
    Ytac0; rewrite (cprod1r cf).
    have nel:= (card_leT le (card_le_succ mB)).
    rewrite (cdiff_wrong nel).
    case: (equal_or_not n m) => eq.
     rewrite eq cdiff_n_n =>//.
    rewrite cdiff_wrong; fprops; move=> el; case: eq; co_tac.
  Ytac0.
  have sm: (succ m) <=c n.
    case: (Bnat_to_el nB mB); first by move => nle; contradiction.
    by move /(card_le_succ_ltP _ mB).
  move: (csucc_diff nB mB sm) => s.
  rewrite {1} s factorial_succ -? s; [ trivial | fprops].
move=> n m nB mB.
rewrite - cprodA; change (Bi n m = Yo (m <=c n) (factorial n) \0 c).
move: n nB m mB; apply: cardinal_c_induction.
  move=> m mB.
  move: (BS_factorial mB) => fi.
  have fc: cardinalp (factorial m) by fprops.
  have cs: (\0 c -c m) = \0 c by rewrite cdiff_wrong; fprops.
  rewrite /Bi cs factorial0 (cprod1r fc) {fi fc cs}.
  move: m mB; apply: cardinal_c_induction.
    rewrite binom00 factorial0; aw; fprops.
    rewrite Y_true; fprops.
  move=> p pB aux.
  have ns: ~ (succ p) <=c \0 c.
    move /(card_le_succ_lt0P (CS_Bnat pB) BS0)=> h';apply: (card_lt0 h').
  by Ytac0;rewrite binom0Sm //cprodC cprod0r.
move=> N NB rN; apply: cardinal_c_induction.
  move: (BS_succ NB) => sB.
  rewrite /Bi (binomSn0 NB) factorial0.
  rewrite (cdiff_n_0 sB).
  rewrite (cprod1l (CS_Bnat (BS_factorial sB))).
  rewrite (cprod1l (CS_Bnat (BS_factorial sB))).
  rewrite Y_true//; fprops.
move => p pB bB.
have spN: inc (succ p) Bnat by fprops.
rewrite (ba4 _ _ NB pB).
rewrite (rN _ pB)(rN _ spN) factorial_succ //.
have Nc: cardinalp N by fprops.
have psc: cardinalp (succ p) by fprops.
have cp: cardinalp p by fprops.
move: (card_lt_succ pB) => psp.
move: (card_le_succ_succP cp (CS_Bnat NB)) => hlp.
case: (card_le_to_el psc Nc) => c1.
  have [pN npN]: p <c N by co_tac.
  have yf:~ (N <=c p) by dneg eql; co_tac.
  Ytac0; Ytac0; Ytac0; move: (pN); move / hlp => pN1; Ytac0.
   rewrite - cprod_sumDl.
  by apply: f_equal; rewrite (Bsucc_rw pB) (Bsucc_rw NB) csumA cdiff_rpr.
have r1: ~ ((succ p) <=c N) by move=> h; co_tac.
Ytac0; rewrite cprodC cprod0r.
move: c1 => /(card_lt_succ_leP pB) c1.
case: (equal_or_not p N) => epN.
  have c2: p <=c N by rewrite epN; fprops.
  move: (c2); rewrite {1} hlp => c2'.
  Ytac0; Ytac0; rewrite epN.
  rewrite csum0l => //; fprops.
have c2: ~(p <=c N) by dneg c3; co_tac.
move: (c2); rewrite {1} hlp => c2'.
Ytac0; Ytac0; rewrite cprodC cprod0r //.
by rewrite (bsum0l BS0).
Qed.

Lemma binom_bad n m: inc n Bnat -> inc m Bnat ->
  n <c m -> binom n m = \0 c.
Proof.
move=> nB mB h; move: (binom_alt_pr nB mB).
have nz: ~ (m <=c n) by move=> h'; co_tac.
Ytac0;move=> p1; ex_middle p2.
have nmB: inc (n -c m) Bnat by fprops.
move: (cprod2_nz (cprod2_nz p2 (factorial_nz mB)) (factorial_nz nmB))=> z4.
contradiction.
Qed.

Lemma binom_good n m: inc n Bnat -> inc m Bnat ->
  m <=c n ->
  (binom n m ) *c (factorial m ) *c (factorial (n -c m)) = (factorial n ).
Proof. by move=> nB mB h; move: (binom_alt_pr nB mB); Ytac0. Qed.

Lemma binom_pr0 n p: inc n Bnat -> inc p Bnat ->
  p <=c n ->
  let num := (factorial n) in
  let den:= (factorial p ) *c (factorial (n -c p)) in
  den %|c num /\ binom n p = num %/c den.
Proof.
move=> nB pB h num den; move: (binom_good nB pB h).
rewrite -/num -/den.
have nuB: inc num Bnat by apply: BS_factorial =>//.
have deB: inc den Bnat by apply: BS_prod;apply: BS_factorial =>//; fprops.
have dnz: den <> \0 c.
   rewrite /den; apply: cprod2_nz; apply: factorial_nz; fprops.
have bN: inc (binom n p) Bnat by apply: BS_binom =>//.
rewrite - cprodA cprodC.
move => rel; split.
  rewrite -rel;apply: cdivides_pr1 =>//.
apply: cdivides_pr2 => //.
Qed.

Lemma binom_pr1 n p: inc n Bnat -> inc p Bnat ->
  p <=c n ->
  binom n p = (factorial n ) %/c ((factorial p ) *c (factorial (n -c p))).
Proof.
by move=> nB pB h; move: (binom_pr0 nB pB h)=> [_].
Qed.

Lemma binom_symmetric n p: inc n Bnat -> inc p Bnat ->
  p <=c n -> binom n p = binom n (n -c p).
Proof.
move => nB pB h.
move: (cdiff_le_symmetry h) => aux.
move: (cdiff_le_symmetry h) => h'.
rewrite (binom_pr1 nB pB h) cprodC (binom_pr1 nB (BS_diff p nB) h').
rewrite double_diff //; apply: le_minus.
Qed.

Lemma binom_symmetric2 n m: inc n Bnat -> inc m Bnat ->
    binom (n +c m) m = binom (n +c m) n.
Proof.
move => nB mB.
rewrite csumC (binom_symmetric (BS_sum mB nB) mB (Bsum_M0le mB nB)).
rewrite csumC (cdiff_pr1 nB mB) //.
Qed.

Lemma binom0 n: inc n Bnat -> binom n \0 c = \1 c.
Proof.
move=> nB.
case: (equal_or_not n \0 c).
  by move=> ->; rewrite binom00.
move=> nz; move: (cpred_pr nB nz)=> [pB] ->.
rewrite binomSn0 //.
Qed.

Lemma binom1 n: inc n Bnat -> binom n \1 c = n.
Proof.
move: n; rewrite - succ_zero;apply: cardinal_c_induction.
  rewrite binom0Sm //; fprops.
move=> p pB r.
by rewrite (binomSnSm pB BS0) r (binom0 pB) (Bsucc_rw pB).
Qed.

Lemma binom2a n: inc n Bnat ->
  \2 c *c (binom (succ n) \2 c ) = n *c (succ n ).
Proof.
move:n ; rewrite -{2} succ_one; apply: cardinal_c_induction.
  symmetry;rewrite cprodC cprod0r.
  rewrite binomSnSm; fprops.
  rewrite binom0Sm; fprops; rewrite binom1;fprops.
  by aw;fprops;rewrite cprod0r.
move=> n nB r; move: (BS_succ nB) => sB.
rewrite (binomSnSm sB BS1).
rewrite cprod_sumDl r (binom1 sB).
rewrite - cprod_sumDr cprodC.
by congr (_ *c _);rewrite - card_two_pr (Bsucc_rw sB) (Bsucc_rw nB) csumA.
Qed.

Lemma binom2 n: inc n Bnat ->
  binom (succ n) \2 c = (n *c (succ n )) %/c \2 c.
Proof.
move=> nB; move: (BS_succ nB) => sB.
apply: (cdivides_pr2 (BS_prod nB sB) BS2 (BS_binom sB BS2) card2_nz).
by rewrite (binom2a nB).
Qed.

Lemma binom_nn n: inc n Bnat -> binom n n = \1 c.
Proof.
move=> nB.
have nn: n <=c n by fprops.
rewrite binom_symmetric// cdiff_n_n //; apply: binom0 =>//.
Qed.

Lemma binom_pr3 n p: inc n Bnat -> inc p Bnat ->
  p <=c n -> binom n p <> \0 c.
Proof.
move=> nB pB h bz; move: (binom_good nB pB h).
rewrite bz - cprodA cprodC cprod0r =>h'.
by case: (factorial_nz nB).
Qed.

Lemma binom_monotone1 k n m:
  inc k Bnat -> inc n Bnat -> inc m Bnat ->
  k <> \0 c -> k <=c (succ n ) -> n <c m ->
  (binom n k ) <c (binom m k ).
Proof.
move: k n m.
have : forall k n, inc k Bnat -> inc n Bnat ->
  k <> \0 c -> k <=c (succ n ) -> (binom n k ) <c (binom (succ n) k ).
  move => k n kB nB r1 r2.
  move: (cpred_pr kB r1) => [pB ps].
  rewrite ps binomSnSm; fprops; rewrite -ps.
  apply: finite_sum4_lt; try apply: BS_binom;fprops.
  apply: binom_pr3 =>//.
  apply /(card_le_succ_succP (CS_Bnat pB) (CS_Bnat nB)); rewrite -ps//.
move=> aux k n m kB nB mB r1 r2 r3.
pose r p := (binom n k) <c (binom p k).
have sn: inc (succ n) Bnat by fprops.
have mi: inc m (interval_cc Bnat_order (succ n) m).
  apply /(Bint_ccP1 sn mB); split; fprops.
  apply /card_le_succ_lt0P; fprops.
apply: (cardinal_c_induction3_v (r:=r) sn mB) =>//.
  rewrite /r; apply: aux =>//.
move => n' /(Bint_coP1 sn mB) [r4 r5].
have r6: (binom n' k) <c (binom (succ n') k).
  apply: aux; fprops; first exact: (BS_lt_int r5 mB).
  have r7: k <=c n' by co_tac.
  exact:(card_leT r7 (card_le_succ0 (proj32 r7))).
rewrite /r; move => [r7 _]; co_tac.
Qed.

Lemma binom_monotone2 k n m:
  inc k Bnat -> inc n Bnat -> inc m Bnat ->
  k <> \0 c -> k <=c (succ n ) -> k <=c (succ m ) ->
  (n <c m <-> (binom n k ) <c (binom m k )).
Proof.
move=> kB nB mB r1 r2 r3.
split.
   apply: binom_monotone1 =>//.
case: (card_le_to_el (CS_Bnat mB) (CS_Bnat nB)) => //.
move=> mn [ble bne].
case: (equal_or_not n m) => nm.
  by rewrite nm in bne; case: bne.
have lmn : m <c n by split => //; apply: nesym.
have bgt: (binom m k) <c (binom n k) by apply: binom_monotone1 =>//.
co_tac.
Qed.

Lemma number_of_partitions_p3 E m p: inc m Bnat -> inc p Bnat ->
  cardinal E = m +c p ->
  cardinal (partitions_pi (variantLc m p) E) =
  binom (m +c p) m.
Proof.
move=> mB pB cE; move: (number_of_partitions_p2 mB pB cE); simpl.
set x:= cardinal _.
set n := factorial _.
set d := (factorial _) *c _.
move=> [p1 p2 p3 p4 p5].
have r1: m <=c (m +c p).
  by apply: csum_M0le; fprops.
have r2:((m +c p) -c m = p) by rewrite csumC; apply: cdiff_pr1; fprops.
rewrite cprodC in p2.
rewrite (cdivides_pr2 p3 p4 p1 p5 p2).
by rewrite (binom_pr1 (BS_sum mB pB) mB r1) r2.
Qed.

Lemma number_of_partitions_p4 E n m: inc n Bnat -> inc m Bnat ->
  cardinal E = n ->
  cardinal (partitions_pi (variantLc m (n -c m)) E) =
  binom n m.
Proof.
move=> nB mB cE.
case: (Bnat_to_el mB nB) => mn.
  move: (cdiff_pr0 nB mB mn) => [sB eql].
  rewrite -eql in cE.
  by rewrite (number_of_partitions_p3 mB sB cE) eql.
rewrite binom_bad // (cdiff_wrong (proj1 mn)).
set w := partitions_pi _ E; case: (emptyset_dichot w).
  move=> ->; apply: cardinal_set0.
move=> [t] /partitions_piP.
move=> pip; move: (pip_prop0 pip)=> aux.
move:pip=>[df cVg [fgf duj ue]].
have ad: inc C0 (domain (variantLc m \0 c)) by bw; fprops.
move: (cVg _ ad); bw=> eq1.
have tA:inc C0 (domain t) by rewrite df; bw; fprops.
move: (sub_smaller (aux _ tA) ); rewrite eq1 cE => eq2.
co_tac.
Qed.

Definition subsets_with_p_elements p E:=
  Zo (powerset E)(fun z=> cardinal z =p).

Lemma subsets_with_p_elements_pr n p E: inc n Bnat -> inc p Bnat ->
  cardinal E = n ->
  binom n p = cardinal (subsets_with_p_elements p E).
Proof.
move=> nB pB cEn.
set src := partitions_pi (variantLc p (n -c p)) E.
set trg:= subsets_with_p_elements p E.
have cn: cardinalp n by fprops.
have cp: cardinalp p by fprops.
case: (card_le_to_el cp cn); last first.
  move=> np; rewrite binom_bad//.
  case: (emptyset_dichot trg).
     by move=> ->; rewrite cardinal_set0.
     move=> [y] /Zo_P [] /setP_P yE cy.
     move: (sub_smaller yE); rewrite cEn cy => pn; co_tac.
move=> pn.
move: (cdiff_pr0 nB pB pn) => [sB ps].
move: (cEn); rewrite -ps; move=> cEn'.
rewrite -(number_of_partitions_p3 pB sB cEn') -/src.
clear cEn'; apply /card_eqP.
exists (Lf (Vg ^~C0) src trg); split => //; aw.
apply: lf_bijective.
- move=> z /partitions_piP pip.
  have ta: inc C0 (domain z) by move: pip => [p1 _]; rewrite p1; bw; fprops.
  apply: Zo_i.
    by move: ((pip_prop0 pip) _ ta) => /setP_P.
  move: pip => [_ cp' _].
  move: cp'; bw =>cp'; rewrite (cp' _ inc_C0_2); bw.
- have aux: forall w, inc w src -> (Vg w C1 = E -s (Vg w C0 )).
    move=> w /partitions_piP.
    move=>[df cVg [fgf duj ue]].
    have dgw: (domain w = C2) by rewrite df; bw.
    red in duj; rewrite dgw in duj.
    case: (duj _ _ inc_C0_2 inc_C1_2) => di1.
      by case: TP_ne.
    set_extens u; rewrite - ue.
      move => h1; apply /setC_P; split.
         union_tac; rewrite dgw; fprops.
      move=> h2; empty_tac1 u.
    move /setC_P=> [] /setUb_P [y]; rewrite dgw; case /C2_P => -> //.
  move=> u v us vs sWa.
  have sWb: Vg u C1 = Vg v C1 by rewrite (aux _ us) (aux _ vs) sWa.
  move: us vs => /partitions_piP [df cVg [fgf _ _]]
/partitions_piP [df' cV'[fgf' _ _]].
  apply: fgraph_exten =>//; first by rewrite df'.
  by rewrite df; bw;move=> x; case /C2_P => ->.
- move=> y /Zo_P [] /setP_P yE cyp.
  have aux:partition_w_fam (partition_with_complement E y) E.
   apply: is_partition_with_complement =>//.
  exists (variantLc y (E -s y)); bw.
  apply /partitions_piP; split => //; bw.
  move=> i itp; try_lvariant itp.
  rewrite (cardinal_setC4) ? cEn ? cyp //; apply /BnatP; ue.
Qed.

Lemma subsets_with_p_elements_pr0 n p: inc n Bnat -> inc p Bnat ->
  binom n p = cardinal (subsets_with_p_elements p n).
Proof.
move=> nB pB.
have cn: (cardinal n = n) by apply: card_card; fprops.
by rewrite (subsets_with_p_elements_pr nB pB cn).
Qed.

Lemma bijective_complement n p E: inc n Bnat -> inc p Bnat ->
  p <=c n -> cardinal E = n ->
  bijection (Lf (complement E)
    (subsets_with_p_elements p E)(subsets_with_p_elements (n -c p) E)).
Proof.
move=> nB pB pn cE.
apply: lf_bijective.
- move=> z /Zo_P [] /setP_P ze p1; apply: Zo_i.
   apply /setP_P;apply: sub_setC.
  rewrite cardinal_setC4 ?cE ?p1 //; apply /BnatP; ue.
- move => u v /Zo_P [] /setP_P h1 _ /Zo_P [] /setP_P h2 _.
  by rewrite -{2}(setC_K h1) -{2}(setC_K h2) => ->.
- move=> y /Zo_P [] /setP_P yE cy;exists (E -s y); last by rewrite (setC_K yE).
  apply: Zo_i.
    apply /setP_P; apply: sub_setC.
  have fse: finite_set E by apply /BnatP; ue.
  rewrite (cardinal_setC4 yE fse) cy cE; apply: double_diff => //.
Qed.

Definition functions_sum_eq E n:=
  Zo (functions E (Bintc n))
  (fun z=> (card_sum (P z)) = n).

Definition graphs_sum_eq F n:=
  fun_image (functions_sum_eq F n) graph.

Definition functions_sum_le E n:=
  Zo (functions E (Bintc n))
  (fun z=> (card_sum (P z)) <=c n).

Definition graphs_sum_le F n:=
  fun_image (functions_sum_le F n) graph.

Lemma setof_suml_auxP F n: inc n Bnat -> forall f,
  inc f (graphs_sum_le F n) <->
  [/\ domain f = F, (card_sum f ) <=c n, fgraph f & cardinal_fam f].
Proof.
move=> nB f.
split.
  move=> /funI_P [z /Zo_P [/fun_set_P [ fz sz tz] cs] ->];split => //.
      rewrite - sz; aw.
     fprops.
  move=> i; rewrite -(proj33 fz) => iz.
  move: (Vf_target fz iz); rewrite tz => WB.
  move: (Bint_S WB); move=> h; fprops.
move=> [df sf fgf alc].
have tf: forall i, inc i F -> inc (Vg f i) (Bintcc \0 c n).
  rewrite -df;move=> i iF.
  set (j := singleton i).
  have sjd: sub j (domain f) by move=> t /set1_P->.
  move: (alc _ iF) => aux.
  move: (csum_increasing1 alc sjd).
  have vr: Vg f i = Vg (restr f j) i by bw; rewrite /j; fprops.
  rewrite vr in aux.
  have dr: (domain (restr f j) = singleton i) by bw.
  rewrite (csum_trivial1 dr aux).
  rewrite -vr; move=> vle0.
  have vle: (Vg f i) <=c n by co_tac.
  apply /Bint_ccP1; fprops.
set z:= triple F (Bintc n) f.
apply /funI_P;exists z; rewrite /z => //; aw.
apply: Zo_i=> //; last by rewrite /triple; aw.
apply /fun_set_P;split => //; aw; apply: function_pr => //.
move=> t /(range_gP fgf) [x xs ->]; apply: tf; ue.
Qed.

Lemma setof_sume_auxP F n: inc n Bnat -> forall f,
  inc f (graphs_sum_eq F n) <->
  [/\ domain f = F, card_sum f = n, fgraph f& cardinal_fam f].
Proof.
move=> nB f; split.
  move=> /funI_P [z /Zo_P [/fun_set_P [ fz sz tz] cs] ->];split => //.
  - rewrite - sz; aw.
  - fprops.
  - move=> i; rewrite -(proj33 fz) => iz.
    by move: (Vf_target fz iz); rewrite tz => /Bint_S /CS_Bnat.
move=> [df sf fgf alc].
have : inc f (graphs_sum_le F n).
   apply /setof_suml_auxP => //; rewrite sf; split;fprops.
move => /funI_P [z /Zo_P [pa _] pb].
apply /funI_P; exists z=> //; apply: Zo_i => //; rewrite - sf pb; aw.
Qed.

Lemma sum_of_gen_binom E F n: inc n Bnat -> cardinal E = n ->
  card_sumb (graphs_sum_eq F n)
              (fun p => cardinal (partitions_pi p E))
  = (cardinal F ) ^c n.
Proof.
move=> cE cEn.
have ->: ((cardinal F) ^c n = F ^c E).
  rewrite - cEn;apply: cpow_pr; fprops.
pose g f i:= (inv_image_by_fun f (singleton i)).
pose f1 f := (Lg F (fun i=> cardinal (g f i))).
pose f2 f := Lg F (g f).
have p1: forall f, inc f (functions E F) ->
     (inc (f1 f) (graphs_sum_eq F n)
      /\ inc (f2 f) (partitions_pi (f1 f) E)).
  move=> f /fun_set_P [ff sf tf].
  have sfa: (source f = unionb (Lg (target f) (g f))).
    set_extens t.
      move => tsf; apply /setUb_P; bw.
      move: (Vf_target ff tsf)=> Wt.
      ex_tac; bw; apply /iim_fun_set1_i => //.
    move => /setUb_P; bw; move => [y ytg]; bw => h.
    by move /(iim_fun_set1_P _ ff): h => [].
  have md: mutually_disjoint (Lg (target f) (g f)).
    apply: mutually_disjoint_prop2.
    move=> i j y itf jtf pa pb.
    by rewrite (iim_fun_set1_hi ff pa) (iim_fun_set1_hi ff pb).
  split; last first.
    rewrite /f1 /f2;apply /partitions_piP; red; bw;split => //.
       move => i iF; bw.
     red; rewrite -tf;split;fprops; ue.
  rewrite /f1; apply /(setof_sume_auxP _ cE);bw;split => //; last first.
    red; red; bw => i iF; bw; fprops.
   fprops.
  rewrite - cEn - sf sfa.
  apply /card_eqP; apply: equipotent_disjointU => //.
    rewrite /disjointU_fam; red;bw; split;fprops.
    move=> i itf; bw; [ eqtrans (cardinal (g f i)); eqsym; fprops | ue].
  apply: mutually_disjoint_prop2; bw => i j y pa pb; bw.
  by move /indexed_P => [_ _ <-] /indexed_P [_ _ <-].
set G:= Lg (graphs_sum_eq F n)
    (fun p => (Zo (functions E F) (fun f=> f1 f = p))).
have g1: unionb G = (functions E F).
  rewrite /G; set_extens f.
    by move /setUb_P ;bw; move => [y ys]; bw; move /Zo_P => [].
  move => fsf ;move: (p1 _ fsf) => [fa fb]; apply /setUb_P; bw.
  by ex_tac;bw; apply: Zo_i.
have g2: mutually_disjoint G.
  by apply: mutually_disjoint_prop2 => i j y ip jp /Zo_hi <- /Zo_hi <-.
symmetry; apply /card_eqP; rewrite -g1.
apply: equipotent_disjointU; fprops; rewrite /G/disjointU_fam; split; bw.
move=> i id; bw.
eqtrans (cardinal (partitions_pi i E)); eqtrans (partitions_pi i E).
set X:= Zo _ _.
exists (Lf f2 X (partitions_pi i E)); aw;split => //; aw.
apply: lf_bijective.
    by move=> t /Zo_P [ts <-]; move: (p1 _ ts) => [].
  move=> u v /Zo_P [] /fun_set_P [fu su tu] f1u
             /Zo_P [] /fun_set_P [fv sv tv] f1v Weq.
  apply: function_exten =>//; try ue.
  move=> x xsu /=.
  have WF: inc (Vf u x) F by Wtac.
  move: (f_equal (Vg ^~(Vf u x)) Weq); rewrite /f2 /g; bw => ieq.
  have : (inc x (inv_image_by_fun u (singleton (Vf u x)))).
     by apply: iim_fun_set1_i.
  by rewrite ieq; move /(iim_fun_set1_hi fv).
move=> y /partitions_piP ys.
move: (pip_prop0 ys)=> pip0.
move: ys=>[df cVg [fgf duj ue]].
have doi: domain i = F by move /(setof_sume_auxP _ cE): id => [].
rewrite doi in cVg.
set xf := fun x => choose (fun j => inc j F /\ inc x (Vg y j)).
have xfp: forall x, inc x E -> (inc (xf x) F /\ inc x (Vg y (xf x))).
  move=> x xE; apply choose_pr.
  move: xE;rewrite -ue => /setUb_P; rewrite df doi.
  by move => [z pa pb]; exists z.
have ta: lf_axiom xf E F by move=> t tE; case:(xfp _ tE).
set x:= Lf xf E F.
have fx: function x by apply: lf_function.
have xsf: inc x (functions E F) by apply /fun_set_P; rewrite /x;red;aw.
have xp1: forall t, inc t F -> g x t = Vg y t.
  move=> t tF; set_extens u.
    move /(iim_fun_set1_P _ fx) => []; rewrite lf_source => uE.
    rewrite /x;aw => -> ; apply : (proj2 (xfp _ uE)).
  move=> uW.
  have usx: inc u (source x).
    by rewrite -doi - df in tF; rewrite /x; aw; apply: (pip0 _ tF).
  apply:(iim_fun_set1_i fx usx).
  move: usx; rewrite /x lf_source => uE; aw.
  move: (xfp _ uE) => [vF tv].
  move: duj; rewrite /mutually_disjoint;aw; rewrite df doi.
  move=> aux; case: (aux _ _ tF vF) => // dj; empty_tac1 u.
have xp2: Lg F (g x) = y.
  symmetry; apply: fgraph_exten =>//; bw; fprops.
    rewrite df //.
  rewrite df doi; move => u uF /=; bw; rewrite - xp1 //.
exists x=>//; apply: Zo_i =>//.
move: id => /(setof_sume_auxP _ cE) [ pa pb pc pd].
apply: fgraph_exten; rewrite /f1; fprops; bw; first by symmetry.
move => a aF /=; bw; rewrite xp1 // cVg //.
Qed.

Lemma sum_of_gen_binom0 E n a:
  inc n Bnat -> cardinal E = n -> finite_int_fam a ->
  (card_sum a ) ^c n =
     card_sumb (graphs_sum_eq (domain a) n)
       (fun p =>
         (cardinal (partitions_pi p E)) *c
            (card_prodb (domain a) (fun i=> ((Vg a i ) ^c (Vg p i ))))).
Proof.
move=> nB cEn fifa.
set F:=card_sum a; set I := domain a.
move: (finite_sum_finite fifa) => sB.
have cF: card_sum a = cardinal F .
  by symmetry; apply: card_card;apply: CS_Bnat.
move: (number_of_partitions1 fifa cF) => [pF].
move /partitions_piP => pipF.
have ->: (F ^c n = F ^c E).
  rewrite - cEn;apply: cpow_pr; fprops.
pose g f i := (inv_image_by_fun f (Vg pF i)).
pose f1 f := (Lg I (fun i=> cardinal (g f i))).
pose f2 f := Lg I (g f).
have g_propP: forall f i, inc f (functions E F) -> inc i I ->
    forall x , inc x (g f i) <-> (inc x E /\ inc (Vf f x) (Vg pF i)).
  move=> f i /fun_set_P [ff sf tf] iI x; rewrite - sf; split.
    rewrite /g; aw; move /iim_fun_P => [u pa pb].
    split; [ Wtac | rewrite - (Vf_pr ff pb) //].
  move => [pa pb]; apply /iim_fun_P; ex_tac; apply: Vf_pr3 =>//.
move: (pip_prop0 pipF) => prop0F.
move:pipF=>[da cVa [fga duja uea]].
have sfa: forall f, inc f (functions E F) -> unionb (Lg I (g f)) = E.
  move=> f fs; move: (fs) => /fun_set_P [ff sf tf].
  symmetry; rewrite - sf;set_extens t => ts.
    move: (Vf_target ff ts).
    rewrite tf -uea; move /setUb_P; rewrite da; move=> [y yda Vy].
    apply /setUb_P;exists y => //; bw; apply/ (g_propP _ _ fs yda).
    split=>//; ue.
  move /setUb_P: ts; bw; move => [y yI]; bw.
  by move /(g_propP _ _ fs yI) => []; rewrite sf.
have sfb: forall f, inc f (functions E F) ->
      mutually_disjoint (Lg I (g f)).
    move=> f fs;apply: mutually_disjoint_prop2.
    move=> i j y iI jI / (g_propP _ _ fs iI) [yE W1]/(g_propP _ _ fs jI) [_ W2].
    red in duja;move: duja;rewrite da; move=> h; case: (h _ _ iI jI)=>// h'.
    empty_tac1 (Vf f y).
have sfc:forall f, inc f (functions E F) ->
     inc (f2 f) (partitions_pi (f1 f) E).
  move=> f fs; rewrite /f1/f2;apply /partitions_piP; red; bw;split => //.
    move => i iF; bw.
  red; aw;split;fprops.
have sfd: forall f, inc f (functions E F) ->
    inc (f1 f) (graphs_sum_eq I n).
  move=> f fs ; apply /(setof_sume_auxP _ nB); rewrite /f1.
  rewrite - cEn -(sfa _ fs);split => //; bw; last first.
     red;red; bw; move => i itf; bw; fprops.
    fprops.
  apply /card_eqP;apply: equipotent_disjointU;fprops.
  split;fprops.
    rewrite /disjointU_fam; bw.
  rewrite /disjointU_fam; bw; move=> i itf; bw.
  eqtrans (cardinal (g f i)); eqsym; fprops.
set G:= Lg (graphs_sum_eq I n)
    (fun p => (Zo (functions E F) (fun f=> f1 f = p))).
have g1: unionb G = (functions E F).
  rewrite /G;set_extens f.
    by move /setUb_P; bw;move=> [y ys]; bw => /Zo_P [].
   move=> fsf;move: (sfd _ fsf) => fa; apply /setUb_P; bw; ex_tac; bw.
   by apply: Zo_i.
have g2: mutually_disjoint G.
  rewrite /G;apply: mutually_disjoint_prop2.
  by move=> i j y ip jp /Zo_hi <- /Zo_hi <-.
  rewrite /f1/partitions_pi /partition_with_pi_elements.
symmetry; apply /card_eqP; rewrite -g1.
apply: equipotent_disjointU; fprops.
rewrite /disjointU_fam Lg_domain.
red; bw;split; first by rewrite /G; bw.
move => p pd; bw.
set X:= (partitions_pi p E).
set Y := productb (Lg I (fun i=> (functions (Vg p i) (Vg pF i)))).
set aux:= _ *c _.
eqtrans aux; first by eqsym; fprops.
eqtrans (product X Y).
  rewrite /aux cprod2_pr1/card_prod; set t:= product _ _; eqtrans t.
  rewrite /t; clear t; apply: equipotent_setX; fprops.
  rewrite /card_prodb /card_prod.
  set t:= productb _ ; eqtrans t.
  rewrite /t; clear t; apply: equipotent_setXb; red;bw;split;fprops.
  move=> i iI; bw; fprops.
  eqtrans (cardinal (functions (Vg p i) (Vg pF i))).
  change (equipotent(card_pow (Vg a i) (Vg p i)) (card_pow (Vg pF i) (Vg p i))).
  have ->: (card_pow (Vg a i) (Vg p i) = card_pow (Vg pF i) (Vg p i)).
     apply: cpow_pr; fprops; rewrite - cVa //; fprops.
  fprops.
clear aux.
set (Z:= (Zo (functions E F) (fun f : Set => f1 f = p))).
have phi1: forall f, inc f Z -> inc (f2 f) X.
   move=> f /Zo_P [fs f1f];rewrite /X -f1f; apply: sfc =>//.
set WI:= fun f i => equipotent_ex (Vg p i) (g f i).
have W1: forall f i, inc f Z -> inc i I ->
  bijection_prop (WI f i) (Vg p i) (g f i).
  move=> f i fZ iI; rewrite /WI; apply: equipotent_ex_pr.
  move: fZ => /Zo_P [fa fb]; rewrite -fb; rewrite /f1; bw; fprops.
have W2: forall f f' i, inc f Z -> inc f' Z-> inc i I ->
    f2 f = f2 f' -> WI f i = WI f' i.
  move=> f f' i fZ f'Z iI sf1; rewrite /WI.
  by move: (f_equal (Vg ^~i) sf1); rewrite /f2; bw; move=> ->.
set WJ:= fun f i => (restriction2 f (g f i) (Vg pF i)) \co (WI f i ).
have W3: forall f i, inc f Z -> inc i I ->
  [/\restriction2_axioms f (g f i) (Vg pF i) ,
   function (restriction2 f (g f i) (Vg pF i)) &
   (restriction2 f (g f i) (Vg pF i)) \coP (WI f i )].
  move=> f i fZ iI.
  move: (W1 _ _ fZ iI) => [bVf sVf tW].
  move: fZ=> /Zo_P [feF f1f].
  move :(g_propP _ _ feF iI) => g1P.
  move: feF => /fun_set_P [ff sf tf].
  have sgi: sub (g f i) (source f).
     by rewrite sf; move=> t /g1P; case.
  have ra:restriction2_axioms f (g f i) (Vg pF i).
    split => //.
      rewrite tf; apply: prop0F; ue.
    by move=> t /(Vf_image_P ff sgi) [u /g1P [uE pr] ->].
  have fr:function (restriction2 f (g f i) (Vg pF i)).
    apply: (proj31 (restriction2_prop ra)).
    by split => //; split => //; [ fct_tac | rewrite /restriction2;aw].
set f3:= fun f => (Lg I (WJ f)).
have phi2: forall f, inc f Z -> inc (f3 f) Y.
  rewrite /f3; move=> f fZ; apply /setXb_P; bw; split => //.
    fprops.
  move=> i iV; bw.
  move: (W3 _ _ fZ iV)(W1 _ _ fZ iV) => [p1 p2 p3][p4 p5 p6].
  rewrite /WJ; apply /fun_set_P.
  split => //;aw; [ fct_tac | rewrite /restriction2; aw].
eqsym.
exists (Lf (fun f =>(J (f2 f) (f3 f))) Z (X \times Y)).
red;aw;rewrite /G; bw; split => //;apply: lf_bijective.
   move=> f fZ; apply:setXp_i; fprops.
  move=> u v uZ vZ eq.
  move: (pr1_def eq)(pr2_def eq)=> sf2 sf3.
  move: (uZ) => /Zo_P [usf _].
  move: (uZ)(vZ) => /Zo_P [] /fun_set_P [fu su tu] f1u
                    /Zo_P [] /fun_set_P [fv sv tv] f1v.
  apply: function_exten =>//; try ue.
  rewrite su -(sfa _ usf); move=> x /setUb_P; bw; move => [i iI]; bw => xgui.
  move: sf3; rewrite /f3 => eq1.
  move: (f_equal (Vg ^~i) eq1); bw; rewrite /WJ => eq2.
  move:(W2 _ _ _ uZ vZ iI sf2) => eq3.
  move: (W3 _ _ uZ iI)(W1 _ _ uZ iI) => [p1 p2 p3][p4 p5 p6].
  move: (W3 _ _ vZ iI)(W1 _ _ vZ iI) => [p7 p8 p9][p10 p11 p12].
  rewrite -p6 in xgui.
  move: p4 => [_ sW]; move: ((proj2 sW) _ xgui) => [y ys vy].
  move: (f_equal (Vf ^~ y) eq2); aw; try ue.
  rewrite (restriction2_V p1); last by rewrite vy -p6.
  rewrite (restriction2_V p7); first by rewrite - eq3 vy //.
  Wtac; [ fct_tac |by rewrite p11 -p5 ].
move=> y /setX_P [py Py Qy].
move: (Py) => /partitions_piP [dy cVy pfay].
move: (pfay) =>[fgy dujy uey].
move: (Qy) => /Zo_P; bw; move=> [_ [fgQ dQ Qv]].
move /(setof_sume_auxP _ nB): (pd) => [fgp dp csp cVip].
set WK:= fun i => equipotent_ex (Vg p i) (Vg (P y) i).
have W4: forall i, inc i I ->
  (bijection_prop (WK i) (Vg p i) (Vg (P y) i)).
  move=> i iI; rewrite /WK; apply: equipotent_ex_pr; rewrite - cVy; fprops; ue.
pose hb i := (canonical_injection (Vg pF i) F) \co
  ((Vg (Q y) i ) \co (inverse_fun (WK i))).
have Hv:forall i, inc i I ->
  [/\ (Vg (Q y) i ) \coP (inverse_fun (WK i)),
   function ( (Vg (Q y) i ) \co (inverse_fun (WK i)))
   & (canonical_injection (Vg pF i) F) \coP
  ((Vg (Q y) i ) \co (inverse_fun (WK i)))].
  move=> i iI.
  move: (W4 _ iI)(Qv _ iI); bw; move => [bVf sw tW].
  move /fun_set_P => [fVg sVg tV].
  have p1: (Vg (Q y)i ) \coP (inverse_fun (WK i)).
    split => //; [ by apply: bijective_inv_f | aw; ue].
  have p2:function ((Vg (Q y) i) \co (inverse_fun (WK i))) by fct_tac.
  split => //;split => //.
    apply: ci_f; apply: prop0F; ue.
  by rewrite /canonical_injection; aw.
have Hw:forall i, inc i I -> function_prop (hb i) (Vg (P y) i) F.
  move=> i iI.
  move: (Hv _ iI) => [p1 p2 p3];rewrite /hb;red.
   rewrite compf_s compf_s compf_t.
  split; first (by fct_tac); last by rewrite /canonical_injection; aw.
  rewrite ifun_s; by move: (W4 _ iI); move => [bVf sw tW].
rewrite -fgp -dy in Hw.
move: (extension_partition1 pfay Hw).
set w := common_ext _ _ _;move => [[fw sw tw] alaw].
rewrite dy fgp in alaw.
have wsf:inc w (functions E F) by apply /fun_set_P.
have gp1: forall j x, inc j I -> inc x (Vg (P y) j) ->
    inc (Vf w x) (Vg pF j).
  move=> j x jI xV.
  move: (alaw _ jI) =>[p1 p2 p3]; rewrite (p3 _ xV).
  move: (Hv _ jI) => [p4 p5 p6].
  move: (W4 _ jI) (Qv _ jI);bw; move => [bWj sWj tWj].
  move /fun_set_P => [fVj sVj tVj].
  rewrite /hb; set aux := (Vg (Q y) j) \co _.
  have xsa: inc x (source aux) by rewrite /aux; aw; rewrite tWj.
  have xta: inc (Vf aux x) (Vg pF j).
       have <-:(target aux = Vg pF j) by rewrite /aux; aw.
       Wtac.
    aw; rewrite ci_V //; apply: prop0F; ue.
have gp2: forall i, inc i I -> g w i = Vg (P y) i.
  move => i iI; set_extens x.
     move /(g_propP _ _ wsf iI) => []; rewrite - uey; move /setUb_P.
     move=> [j]; rewrite dy fgp => jI xVj pa.
     move: (gp1 _ _ jI xVj) => Wp'.
     red in duja; rewrite da in duja; case: (duja _ _ iI jI) => h; try ue.
     empty_tac1 (Vf w x).
  move: (alaw _ iI)=> [p1 p2 p3] p4; apply /(g_propP _ _ wsf iI).
  split; first by rewrite - sw; apply: p1.
  by apply: gp1.
have wZ:inc w Z.
  apply: Zo_i => //.
  apply: fgraph_exten =>//;rewrite /f1; bw; fprops; try ue.
  move=> x xI /=; bw; rewrite gp2 //; apply: cVy; ue.
ex_tac.
have ->: (f2 w = P y).
  apply: fgraph_exten =>//;rewrite /f2; bw; fprops; try ue.
  move=> x xI /=; bw; rewrite gp2 =>//.
suff: (f3 w = Q y) by move=> ->; aw.
apply: fgraph_exten =>//;rewrite /f3; bw; fprops; try ue.
move => i iI; bw.
move: (W4 _ iI)(Qv _ iI); bw; move => [bVf sVf tW].
move => /fun_set_P [fVg sVg tV].
have ww: (WI w i = WK i) by rewrite /WI /WK gp2 //.
move: (W3 _ _ wZ iI); rewrite /WJ ww (gp2 _ iI); move => [ra rd cr].
apply: function_exten.
- apply: compf_f =>//; aw; ue.
- exact fVg.
- aw; ue.
- aw; rewrite /restriction2; aw; ue.
- have fW: function (WK i) by fct_tac.
aw; move=> x xs.
have p1:inc (Vf (WK i)x ) (target (WK i)) by Wtac.
move: (p1); rewrite tW => p11.
rewrite compf_V //restriction2_V //.
move: (alaw _ iI)=> [_ _ p3]; rewrite -tW in p3;rewrite (p3 _ p1).
rewrite /hb.
have p2: (Vg (Q y) i) \coP (inverse_fun (WK i)).
  split => //; [ by apply: bijective_inv_f | aw; ue].
have p0:function ((Vg (Q y) i) \co (inverse_fun (WK i))) by fct_tac.
rewrite da in prop0F; move: (@prop0F i iI)=> pf0.
have p4: (canonical_injection (Vg pF i) F) \coP
        ( (Vg (Q y) i) \co (inverse_fun (WK i))).
  split;fprops.
  by rewrite /canonical_injection; aw.
aw.
have <-: x = Vf (inverse_fun (WK i)) (Vf (WK i) x) by rewrite inverse_V2 =>//.
by rewrite ci_V // -tV //; Wtac; rewrite sVg - sVf.
Qed.

Lemma sum_of_gen_binom2 n: inc n Bnat ->
  card_sumb (Bintc n) (binom n) = \2 c ^c n.
Proof.
move=> nB; symmetry.
have cnn:=(card_card (CS_Bnat nB)).
rewrite -(cardinal_set2 TP_ne) -/C2 - (sum_of_gen_binom C2 nB cnn).
set f:= fun m => (variantLc m (n -c m)).
have p1: forall m, inc m (Bintc n) ->
   inc (f m) (graphs_sum_eq C2 n).
  move=> m /Bintc_i mn.
  rewrite /f;apply /(setof_sume_auxP _ nB);split => //;bw.
      apply: (cdiff_pr mn).
    fprops.
  hnf; bw => i itp; try_lvariant itp; [ co_tac | fprops ].
rewrite /card_sumb (csum_Cn2 (I:=Bintc n) (f:= f));first last.
split => //; bw.
    rewrite /f;move=> u v ui vi s.
    move: (f_equal (Vg ^~C0) s); bw.
  move=> y / (setof_sume_auxP _ nB) [dy sy fgy alc].
  rewrite /cardinal_fam /allf dy in alc.
  move: (alc _ inc_C0_2) (alc _ inc_C1_2) => ca cb.
  have abn: (Vg y C0 ) +c (Vg y C1 ) = n.
     rewrite - sy; apply: csum2_pr.
     exists C0; exists C1; rewrite dy;split;fprops.
  move: (nB); rewrite -abn => nB'.
  move: (Bnat_in_sum2 ca nB')(Bnat_in_sum cb nB') => aB bB.
  move: (csum_M0le (Vg y C1) ca); rewrite abn => an.
  exists (Vg y C0); first by apply /BintcP.
  rewrite /f;apply: fgraph_exten; bw; fprops.
  rewrite dy;move=> x xtp; try_lvariant xtp.
  rewrite -abn csumC cdiff_pr1 //.
congr (card_sum _); apply: Lg_exten => x xi /=;bw; last by apply: p1.
by rewrite (number_of_partitions_p4 nB (@Bint_S \0 c n _ xi) cnn).
Qed.

Lemma sum_of_binomial n: inc n Bnat ->
  card_sumb (Bintc n) (binom n) = \2 c ^c n.
Proof.
move=> nB.
rewrite - card_setP.
set (idx:= Bintc n).
set (X:= Lg idx (fun p=>subsets_with_p_elements p n)).
set (Y:= disjointU_fam X).
have fgX: fgraph X by rewrite/ X; fprops.
have fgY: fgraph Y by rewrite /Y/disjointU_fam; fprops.
have dx: domain X = domain Y by rewrite /Y/disjointU_fam; bw.
have eqv: forall i, inc i (domain X) -> equipotent (Vg X i) (Vg Y i).
  move=> i idX; rewrite /Y/disjointU_fam; bw;fprops.
have mdX: mutually_disjoint X.
   apply: mutually_disjoint_prop2.
   move=> i j y id jd;rewrite / subsets_with_p_elements.
   by move=> /Zo_hi yi /Zo_hi yj; rewrite -yi -yj.
have mdY: mutually_disjoint Y by rewrite /Y; fprops.
move:(equipotent_disjointU (conj dx eqv) mdX mdY).
have ->:unionb X = powerset n.
  rewrite /X; set_extens t.
     by move /setUb_P; bw; move=> [y ydx]; bw; move /Zo_P => [].
  move => tp; apply /setUb_P; bw.
  have cxi: (inc (cardinal t) idx).
     apply /(BintcP nB); move: (tp) => /setP_P /sub_smaller.
     by rewrite (card_card (CS_Bnat nB)).
  by ex_tac; bw; apply: Zo_i.
move /card_eqP ->.
apply: csum_pr3; fprops; rewrite /X;bw => i ix; bw.
move: (@Bint_S \0 c n _ ix) => iB.
rewrite - subsets_with_p_elements_pr0 //.
exact: (card_card (CS_Bnat (BS_binom nB iB))).
Qed.

Lemma sum_of_binomial2 a b n:
  cardinalp a -> cardinalp b -> inc n Bnat ->
  card_sumb (Bintc n)
         (fun p => (binom n p ) *c (a ^c p ) *c (b ^c (n -c p )))
  = (a +c b ) ^c n.
Proof.
move=> ca cb nB.
move: n nB; apply: cardinal_c_induction.
  rewrite cpowx0 /card_sumb.
  set f := Lg _ _.
  have zi: inc \0 c (Bintc \0 c) by apply /BintcP; fprops.
  have df: domain f = singleton \0 c by rewrite /f; bw; apply: Bint_cc00.
  have xo: Vg f \0 c = \1 c.
    rewrite /f; bw.
    rewrite cdiff_n_n // cpowx0 // cpowx0 // binom00; aw; fprops.
  rewrite (csum_trivial1 df) //; rewrite xo; fprops.
move=> n nB.
rewrite {1} /card_sumb; set fn := Lg _ _.
move=> hrec.
set X:=((a +c b) ^c n).
set I := (Bintc n).
have IB:sub I Bnat by apply: Bint_S.
pose q0 i := (a ^c i ) *c (b ^c (n -c i )).
pose q1 i := (a ^c (succ i )) *c (b ^c ((succ n) -c (succ i ))).
pose f1 i := (binom n (succ i)) *c (q1 i ).
pose f2 i := (binom n i ) *c (q1 i ).
pose g1 i := (binom n i ) *c (a ^c i ) *c (b ^c ((succ n) -c i )).
have P1: card_sum (Lg I f2) = a *c X.
  pose g i:= a *c (binom n i ) *c (q0 i ).
  have ->: Lg I f2 = Lg I g.
    apply: Lg_exten.
    move=> x xi; rewrite /f2 /g (cprodC a _) - cprodA.
    congr (_ *c _); rewrite cprodC /q1 /q0.
    rewrite (cdiff_pr6 nB (IB _ xi)).
    rewrite (Bsucc_rw (IB _ xi)) cpow_sum2 cpowx1 //.
    rewrite - !cprodA; congr (_ *c _); apply: cprodC.
  symmetry;rewrite /X -hrec.
  rewrite (cprod2_sumDn a fn).
  rewrite /fn Lg_domain; congr (card_sum _); apply: Lg_exten.
  move=> x xI /=; bw.
  rewrite cprodA cprodA - cprodA //.
have P2: card_sum (Lg I g1) = b *c X.
  set (g:= fun i=> b *c ((binom n i ) *c (q0 i ))).
  have ->: Lg I g1 = Lg I g.
    apply: Lg_exten.
    move=> x xi /=; rewrite /g1/g (cprodC b _) - ! cprodA.
    have aux:= (Bsucc_rw (BS_diff x nB)).
    have h: succ (n -c x) +c x = succ n.
      move: xi => /(BintcP nB) /cdiff_pr => h.
      by rewrite aux csumC csumA h (Bsucc_rw nB).
    rewrite (cdiff_pr2 (BS_succ (BS_diff x nB)) (IB _ xi) h).
    rewrite aux cpow_sum2 cpowx1; fprops.
  symmetry;rewrite /X -hrec.
  rewrite (cprod2_sumDn b fn).
  rewrite /fn Lg_domain; congr (card_sum _); apply: Lg_exten.
  move=> x xI /=; bw; rewrite /g /q0.
  congr (_ *c _); symmetry; apply: cprodA.
clear hrec fn.
rewrite fct_sum_rec1//.
have sn: inc (succ n) Bnat by fprops.
have a1: cardinalp (card_pow b (succ n)) by rewrite /card_pow; fprops.
rewrite (binomSn0 nB) cpowx0 (cdiff_n_0 sn) (cprod1l CS1) (cprod1l a1).
set ffn:= fun i => _.
move: (sum_of_sums f1 f2 I); rewrite /card_sumb.
have ->:Lg I (fun i => (f1 i ) +c (f2 i )) = (Lg I ffn).
  apply: Lg_exten => i iI.
  have iB: inc i Bnat by apply: IB.
  by rewrite /ffn -/(q1 i) /f1 /f2 (binomSnSm nB iB) - cprodA cprod_sumDr.
have g1z: (g1 \0 c ) = (b ^c (succ n)).
   rewrite /g1 cpowx0 (cdiff_n_0 sn) (binom0 nB).
   by rewrite (cprod1l CS1)(cprod1l (CS_pow b (succ n))).
rewrite -g1z => <-.
have {P1} ->: (card_sum (Lg I f2)) = a *c X by apply: P1.
rewrite (csumC _ (a *c X)) - csumA.
have cz:cardinalp (g1 \0 c) by rewrite g1z /card_pow; fprops.
move: (fct_sum_rec1 g1 nB).
have P3: card_sum (Lg (Bintc (succ n)) g1)= b *c X.
  rewrite -P2 /I.
  have gp: (forall a, inc a Bnat -> cardinalp (g1 a)).
    move=> u uB; rewrite /g1; apply: CS_prod2.
  move: (induction_on_sum g1 sn) => /=.
  rewrite (Bint_co_cc sn) (Bint_co_cc nB) /card_sumb => <-.
  move: (card_lt_succ nB) => aux.
  have ->: (g1 (succ n) = \0 c).
    by rewrite /g1 (binom_bad nB sn aux) - cprodA cprodC; apply: cprod0r.
  rewrite csum0r // /card_sum; fprops.
have p1: Lg I (fun i : Set => g1 (succ i)) = (Lg I f1).
  apply: Lg_exten; move=> u uI; rewrite /f1 /g1 - cprodA //.
rewrite /card_sumb -/I p1; move=> <-.
rewrite P3 - cprod_sumDr cprodC (Bsucc_rw nB) cpow_sum2 cpowx1; fprops.
Qed.

Definition functions_incr r r' :=
  (Zo (functions (substrate r) (substrate r'))
    (fun z => increasing_fun z r r')).
Definition functions_sincr r r' :=
  (Zo (functions (substrate r) (substrate r'))
    (fun z => strict_increasing_fun z r r')).

Lemma cardinal_set_of_increasing_functions1 r r' f:
  total_order r -> strict_increasing_fun f r r' ->
  (order_morphism f r r' /\ cardinal (substrate r) = cardinal (image_of_fun f)).
Proof.
move=> tor si.
move: (total_order_increasing_morphism tor si) => mor; split =>//.
move: (order_morphism_fi mor) => injf.
move: (restriction_to_image_fb injf)=> bj.
move: mor=> [_ _ [_ <- _] _ ].
apply /card_eqP; exists (restriction_to_image f).
split =>//; rewrite /restriction_to_image /restriction2; aw; split => //.
Qed.

Lemma cardinal_set_of_increasing_functions2 r r':
  total_order r -> total_order r' ->
  finite_set (substrate r) -> finite_set (substrate r') ->
  bijection (Lf (fun z => range (graph z))
     (functions_sincr r r')
    (subsets_with_p_elements (cardinal (substrate r)) (substrate r'))).
Proof.
move=> tor tor' fsr fsr'.
rewrite /functions_sincr.
set src:=Zo _ _.
set trg:= subsets_with_p_elements _ _.
set f:= Lf(fun z=> range (graph z)) src trg.
have ta: lf_axiom (fun z=> range (graph z)) src trg.
  move=> z /Zo_P [] /fun_set_P [fz sc tc] siz.
  move: (image_by_fun_source fz)=> imc.
  move:(cardinal_set_of_increasing_functions1 tor siz)=> [morz cs].
  apply /Zo_P; rewrite cs imc - tc;split => //; apply /setP_P.
  by apply: f_range_graph.
apply: lf_bijective =>//.
  move=> u v /Zo_P [] /fun_set_P [fu su tu] siu
    /Zo_P [] /fun_set_P [fv sv tv] siv sr.
  apply: function_exten =>//; [rewrite sv // | rewrite tv //|].
  move=> x xsu; ex_middle Wx.
  move: (finite_set_torder_wor tor fsr) => [or wor].
  set Z := Zo (substrate r) (fun x=> Vf u x <> Vf v x).
  have p1: sub Z (substrate r) by apply: Zo_S.
  have p2: nonempty Z by exists x; apply: Zo_i => //; ue.
  move: (wor _ p1 p2)=> [y []]; aw; move => p3 p4.
  move: p3 =>/Zo_P; rewrite - sv; move => [ysv Wy].
  have le: forall t, glt r t y -> Vf u t = Vf v t.
    move=> t ty; ex_middle Wt.
    have tZ: inc t Z by apply: Zo_i =>//; order_tac.
    move:(iorder_gle1 (p4 _ tZ)) => yt.
    order_tac.
  move: (order_morphism_fi(total_order_increasing_morphism tor siu)) => iu.
  move: (order_morphism_fi(total_order_increasing_morphism tor siv)) => iv.
  move: iu iv => [_ iu] [_ iv]; rewrite su - sv in iu.
  have: inc (Vf u y) (range (graph v)).
     rewrite - sr; Wtac; rewrite su - sv //.
  move /(range_fP fv) => [a asv Wa].
  have ya: glt r y a.
    move: (@total_order_pr2 r a y tor); rewrite - sv; move=> aux.
    case: (aux asv ysv) => h.
      rewrite - (le _ h) in Wa.
      by move: h; rewrite (iu _ _ ysv asv Wa); case.
    split =>//; move => h'; rewrite -h' in Wa; contradiction.
  have: inc (Vf v y) (range (graph u)) by rewrite sr; Wtac.
  move /(range_fP fu); rewrite su - sv; move=> [b bsv Wb].
  have yb: glt r y b.
    move: (@total_order_pr2 r b y tor); rewrite - sv; move=> aux.
    case: (aux bsv ysv) => h.
      rewrite (le _ h) in Wb.
      by move: h; rewrite (iv _ _ ysv bsv Wb); case.
      split =>//; move => h'; rewrite -h' in Wb; by case: Wy.
  move: siv =>[_ _ _ siv]; move: (siv _ _ ya); rewrite -Wa => h1.
  move: siu =>[_ w _ siu]; move: (siu _ _ yb); rewrite -Wb; move => h2.
  order_tac.
have or':order r' by move: tor' => [tor' _].
move=> y /Zo_P [] /setP_P ys /card_eqP ey.
move: (total_order_sub tor' ys).
set (r'' := induced_order r' y).
move=> tor''.
have sr'': (substrate r'' = y) by rewrite /r''; aw.
have e1: ( (substrate r) \Eq (substrate r'')) by rewrite sr''; eqsym.
move: (isomorphism_worder_finite tor tor'' fsr e1) => [g [gi _]].
move: (gi)=> [_ _ [bg sg tg] ig].
have cc: ((canonical_injection y (substrate r')) \coP g).
  split => // ; [fprops | fct_tac | rewrite / canonical_injection - sr''; aw].
  done.
set (x:= (canonical_injection y (substrate r')) \co g).
have fg: (function x) by rewrite /x; fct_tac.
have sx: (source x = substrate r) by rewrite /x - sg; aw.
have tx: target x = substrate r' by rewrite /x/canonical_injection; aw.
have gp: forall a, inc a (source g) -> inc (Vf g a) y.
   rewrite - sr'' - tg; move=> a asg; Wtac; fct_tac.
have xp: forall a, inc a (source g) -> Vf x a = Vf g a.
   move=> a ag; rewrite /x; aw; rewrite ci_V //; apply: gp=>//.
have gxp: forall a, inc a (source g) -> inc (Vf x a) y.
   move=> a ax; rewrite xp //; apply: gp=>//.
move: bg => [[fcg ing] sug].
have xsr: inc x src.
  rewrite /src; apply: Zo_i => //; first by apply /fun_set_P.
  split => //; first by move: tor=> [tor _].
  move=> a b [ab nab].
  have asx: (inc a (source g)) by rewrite sg; order_tac.
  have bsx: (inc b (source g)) by rewrite sg; order_tac.
  rewrite (xp _ asx) (xp _ bsx).
  move: ab;rewrite (ig _ _ asx bsx) /r'' => h.
  split; [exact: (iorder_gle1 h) | dneg nW; apply: ing =>// ].
ex_tac.
set_extens t.
  rewrite - sr'' - tg=> tt; move: ((proj2 sug) _ tt)=> [a asx av].
  apply /(range_fP fg); rewrite sx - sg -av -(xp _ asx); ex_tac.
move /(range_fP fg) => [u].
rewrite sx - sg => us tw; rewrite tw; apply: gxp =>//.
Qed.

Lemma cardinal_set_of_increasing_functions r r':
  total_order r -> total_order r' ->
  finite_set (substrate r) -> finite_set (substrate r') ->
  cardinal (functions_sincr r r')
  = binom (cardinal (substrate r')) (cardinal (substrate r)).
Proof.
move=> tor tor' fsr fsr'.
move: (cardinal_set_of_increasing_functions2 tor tor' fsr fsr').
set src := functions_sincr r r'.
set trg := subsets_with_p_elements _ _.
move=> h.
have -> :cardinal src = cardinal trg.
  apply /card_eqP.
  exists (Lf (fun z : Set => range (graph z)) src trg); split => //; aw.
rewrite /trg.
symmetry;set n := cardinal _; set p := cardinal _.
have nB: inc n Bnat by apply /BnatP; apply: fsr'.
have pB: inc p Bnat by apply /BnatP; apply: fsr.
have cE: cardinal (substrate r') = n by [].
by rewrite (subsets_with_p_elements_pr nB pB cE).
Qed.

Lemma increasing_prop0 p f r: inc p Bnat -> order r ->
  (forall i, i <=c p -> inc (f i) (substrate r)) ->
  (forall n, n <c p -> gle r (f n) (f (succ n))) ->
  (forall i j, i <=c j -> j <=c p ->
    gle r (f i) (f j)).
Proof.
move=> pB or als hyp i j ij jp.
have jB: inc j Bnat by Bnat_tac.
have iB: inc i Bnat by Bnat_tac.
move:(cdiff_pr0 jB iB ij).
set k := (j -c i); move=> [kB ikj]; rewrite -ikj.
have ckk: k <=c k by fprops.
set (pr:= fun n => (n <=c k) -> gle r (f i) (f (i +c n))).
apply: (cardinal_c_induction (r:= pr)) =>//.
  move=> aux; aw; [ order_tac; apply: als; co_tac | fprops ].
move => n nB prn h.
have le2: n <c (succ n) by bw; fprops.
have le4: (i +c n) <c p.
  have le3: n <c k by co_tac.
  move: (csum_Mlteq iB kB le3).
  rewrite csumC (csumC k i) ikj => le4; co_tac.
move: (hyp _ le4).
have -> : (succ (i +c n) = (i +c (succ n))) by rewrite - csum_via_succ //.
move=> r1;move: le2 => [le2 _].
have le3: n <=c k by co_tac.
move: (prn le3) => r2; order_tac.
Qed.

Lemma strict_increasing_prop0 p f r: inc p Bnat -> order r ->
  (forall n, n <c p -> glt r (f n) (f (succ n))) ->
  (forall i j, i <c j -> j <=c p ->
    glt r (f i) (f j)).
Proof.
move=> pB or hyp i j ij jp.
have jB: inc j Bnat by Bnat_tac.
have iB: inc i Bnat by move: ij => [ij _ ];Bnat_tac.
have ip: i <c p by co_tac.
move: ij; move /(card_le_succ_ltP _ iB) => ij.
have siB: inc (succ i) Bnat by fprops.
move:(cdiff_pr0 jB siB ij).
set k := (j -c (succ i)); move=> [kB ikj]; rewrite -ikj.
have ckk: k <=c k by fprops.
set pr:= fun n => (n <=c k) -> glt r (f i) (f ((succ i) +c n)).
apply: (cardinal_c_induction (r:= pr)) =>//.
  move=> aux; aw; [ apply: hyp =>// | fprops].
move => n nB prn h.
set m := succ (i +c n).
have mv: m = ((succ i) +c n).
  rewrite csumC /m csumC csum_via_succ//.
have <-: (succ m = (succ i) +c (succ n)).
   rewrite mv (Bsucc_rw iB) (Bsucc_rw nB) csumA.
   move: BS1 => b1; rewrite Bsucc_rw //; fprops.
have le2: n <c (succ n) by bw; fprops.
have ltkn: n <c k by co_tac.
have mp: m <c p.
  move: (csum_Mlteq siB kB ltkn);rewrite csumC -mv csumC ikj => hh; co_tac.
move: (hyp _ mp) => r1.
move: ltkn => [ltkn _];move: (prn ltkn).
rewrite -mv; move => [r2 _]; order_tac.
Qed.

Lemma increasing_prop p f r: inc p Bnat -> function f ->
  source f = Bint (succ p) -> order r -> substrate r = target f ->
  (forall n, n <c p -> gle r (Vf f n) (Vf f (succ n))) ->
  increasing_fun f (Bint_cco \0 c p) r.
Proof.
move=> pB ff sf or sr sge.
have zB: inc \0 c Bnat by fprops.
have bi:Bintc p = source f by rewrite sf; apply: Bint_co_cc =>//.
move: (Binto_wor \0 c p) => [pa pb].
move: (worder_total pa) => [sor _ ].
split => //.
  by rewrite pb.
move=> x y /Binto_gleP [xs ys lxy].
move: ys => /(BintcP pB) yp.
have aux: (forall i, i <=c p -> inc (Vf f i) (substrate r)).
  by move=> i ip; Wtac; rewrite sf; apply /BintsP.
exact: (increasing_prop0 pB or aux sge lxy yp).
Qed.

Lemma strict_increasing_prop p f r: inc p Bnat -> function f ->
  source f = Bint (succ p) -> order r -> substrate r = target f ->
  (forall n, n <c p -> glt r (Vf f n) (Vf f (succ n))) ->
  (injection f /\
    strict_increasing_fun f (Bint_cco \0 c p) r).
Proof.
move => pB ff sf or sr prop.
have zB: inc \0 c Bnat by fprops.
have bi:Bintc p = source f by rewrite sf; apply: Bint_co_cc =>//.
move: (Binto_wor \0 c p) => [pa pb].
move: (worder_total pa) => tor.
have sic: (strict_increasing_fun f (Bint_cco \0 c p) r).
  split => //.
      by move: tor => [sor _].
    by rewrite pb.
    move=> x y [] /Binto_gleP [xs ys lxy] xne.
    move: ys => /(BintcP pB) yp.
    have ltxy: x <c y by split.
    apply: (strict_increasing_prop0 pB or prop ltxy yp).
split=>//.
move: (total_order_increasing_morphism tor sic).
apply: order_morphism_fi.
Qed.

Lemma strict_increasing_prop1 f p:
  inc p Bnat -> (forall i, i <c p -> inc (f i) Bnat)
  -> (forall i j, i <c j -> j <c p -> (f i ) <c (f j )) ->
  (forall i, i <c p -> i <=c (f i )).
Proof.
move=> pB ali hi i lip.
have iB: (inc i Bnat) by move: lip=> [leip _]; Bnat_tac.
move: i iB lip; apply: cardinal_c_induction.
  move=> aux;apply: czero_least.
  move: (ali _ aux); fprops.
move=> n nB pn aux.
have le2:=(card_lt_succ nB).
have le3:=(hi _ _ le2 aux).
have le4:= (pn (card_lt_ltT le2 aux)).
apply /card_le_succ_lt0P; [ co_tac | fprops | co_tac ].
Qed.

Lemma increasing_prop1 p f: inc p Bnat ->
  (forall i, i <=c p -> inc (f i) Bnat) ->
  (forall n, n <c p -> (f n ) <=c (f (succ n))) ->
  (forall i j, i <=c j -> j <=c p -> (f i ) <=c (f j )).
Proof.
move => pB p1 p2 i j ij jp.
move: (Bnat_order_wor) => [[or _] sr].
set r := Bnat_order.
have q1: (forall i, i <=c p -> inc (f i) (substrate r)).
  by rewrite sr.
have q2:(forall n, n <c p -> gle r (f n) (f (succ n))).
  move=> n np; apply/ Bnat_order_leP; split;fprops.
    by apply: p1; move: np => [np _].
  apply: p1; apply /card_le_succ_lt0P => //; fprops.
  by move: np=> [[cn _] _].
move: (increasing_prop0 pB or q1 q2 ij jp).
by move /Bnat_order_leP => [_ _].
Qed.

Lemma strict_increasing_prop2 f p:
  inc p Bnat -> (forall i, i <c p -> inc (f i) Bnat)
  -> (forall i j, i <c j -> j <c p -> (f i ) <c (f j )) ->
  (forall i j, i <=c j -> j <c p -> ((f i ) -c i ) <=c ((f j ) -c j )).
Proof.
move=> pB ali hyp.
case: (equal_or_not p \0 c).
  move => -> i j ij jp; case: (card_lt0 jp).
move=> pnz.
move:(cpred_pr pB pnz) => [qB ps].
set q := cpred p.
have fq: finite_c (cpred p) by fprops.
set (g:= fun i=> ((f i ) -c i)).
have q1: (forall i : Set, i <=c q -> inc (g i) Bnat).
  move=> i ip;
  have iB: inc i Bnat by Bnat_tac.
  rewrite /g; apply: BS_diff =>//.
  by apply: ali; rewrite ps //; apply /card_lt_succ_leP.
have q2:forall n : Set, n <c q -> (g n ) <=c (g (succ n)).
  move=> n np.
  have nB: inc n Bnat by move: np => [np _]; Bnat_tac.
  have nsB: inc (succ n) Bnat by fprops.
  rewrite /g.
  move:(strict_increasing_prop1 pB ali hyp) => hy.
  have p1: (succ n) <c p.
   rewrite ps ; apply /(card_lt_succ_leP qB) /card_le_succ_lt0P=> //; fprops.
  have p2: n <c p.
     move: (card_le_succ nB)=> aux.
     co_tac.
  move: (hy _ p1) (hy _ p2)=> qp1 qp2.
  move: (ali _ p1)(ali _ p2) => s1 s2.
  move:(cdiff_pr0 s1 nsB qp1)(cdiff_pr0 s2 nB qp2).
  set a:= (f (succ n)) -c (succ n).
  set b := ((f n) -c n).
  move=> [aB r1][bB r2].
  have nsn: n <c (succ n) by fprops.
  move: (hyp _ _ nsn p1);rewrite -r1 -r2.
  have->: ((succ n) +c a = succ (n +c a)).
    by rewrite csumC (csum_via_succ _ nB) csumC.
  move /(card_lt_succ_leP (BS_sum nB aB)); apply: csum_le_simplifiable =>//.
move=> i j ij jp.
apply: (increasing_prop1 qB q1 q2 ij).
by move: jp; rewrite {1} ps; move /(card_lt_succ_leP qB).
Qed.

Lemma strict_increasing_prop3 f p n:
  inc p Bnat -> inc n Bnat -> (forall i, i <c p -> inc (f i) Bnat)
  -> (forall i j, i <c j -> j <c p -> (f i ) <c (f j )) ->
  (forall i, i <c p -> (f i ) <c (n +c p )) ->
  (forall i, i <c p -> ((f i ) -c i ) <=c n).
Proof.
move=> pB nB ali fi fb.
move=> i ip.
case: (equal_or_not p \0 c) => h.
  rewrite h in ip;case: (card_lt0 ip).
move: (cpred_pr pB h) => [qB psq].
move:ip; rewrite psq; move /(card_lt_succ_leP qB)=> iq.
have qp: ((cpred p) <c p) by rewrite {2} psq; bw; fprops.
apply: (@card_leT _ ((f (cpred p)) -c (cpred p))).
  by move: (strict_increasing_prop2 pB ali fi iq qp).
move: (strict_increasing_prop1 pB ali fi qp) => aa.
have fB: (inc (f (cpred p)) Bnat) by apply: ali =>//.
move: (cdiff_pr aa) => csp.
move: (fb _ qp); rewrite - csp.
set (r:= ((f (cpred p)) -c (cpred p))).
have rB: inc r Bnat by rewrite /r;fprops.
have ->: (n +c p = succ ( (cpred p) +c n)).
  by rewrite {1} psq (csum_via_succ _ qB) csumC.
move=> hh.
have sB: inc ((cpred p) +c n) Bnat by fprops.
apply: (@csum_le_simplifiable (cpred p)); fprops.
rewrite cdiff_pr //; first by move /(card_lt_succ_leP sB): hh.
apply: csum_M0le; fprops.
Qed.

Lemma cardinal_set_of_increasing_functions3 n p:
  inc n Bnat -> inc p Bnat ->
  cardinal (functions_incr (Bint_co p)
         (Bint_cco \0 c n))
   = binom (n +c p) p.
Proof.
move=> nB pB.
set r := (Bint_co p).
set r' := (Bint_cco \0 c n).
set (E1:=Bint p).
have s1: E1= substrate r by rewrite /E1 (proj2 (Bintco_wor _)).
set E2:=Bintc n.
have s2: (E2= substrate r') by rewrite /E2 (proj2 (Binto_wor _ _)); fprops.
set np := n +c p.
have npB: inc np Bnat by rewrite /np; fprops.
set (r'':= Bint_co np).
set (E3:=Bint np).
have s3: E3= substrate r'' by rewrite /E3 - (proj2 (Bintco_wor _)).
set Q1:= functions_incr r r'.
set Q2:= functions_sincr r r''.
set (P1:= fun x => function_prop x E1 E2 /\ increasing_fun x r r').
set (P2:= fun x => function_prop x E1 E3 /\ strict_increasing_fun x r r'').
have HQ1P: forall x, inc x Q1 <-> P1 x.
  move=> x; rewrite /Q1 /P1 s1 s2; split.
      by move => /Zo_P [] /fun_set_P pa pd.
      by move => [pa pb]; apply: Zo_i => //; apply /fun_set_P.
have HQ2P: forall x, inc x Q2 <-> P2 x.
  move=> x; rewrite /Q2 /P2 s1 s3; split.
      by move => /Zo_P [] /fun_set_P pa pd.
      by move => [pa pd]; apply: Zo_i => //; apply /fun_set_P.
have E1B :sub E1 Bnat by rewrite /E1; apply: Bint_S1.
have E2B :sub E2 Bnat by rewrite /E2; apply: Bint_S.
have E3B :sub E3 Bnat by rewrite /E3; apply: Bint_S1.
set (subi:= fun f => Lf (fun i=> (Vf f i ) -c i) E1 E2).
have Hi0:forall f, inc f Q2 ->
   [/\ (forall i, i <c p -> inc (Vf f i) Bnat),
    (forall i j, i <c j -> j <c p -> (Vf f i ) <c (Vf f j )) &
    (forall i, inc i E1 -> (i <=c (Vf f i )))].
  move=> f /HQ2P [[ff sf tf] sif].
  have aux: (forall i, i <c p -> inc (Vf f i) Bnat).
    by move=> i ilp; apply: E3B =>//; Wtac; rewrite sf /E1; apply/BintP.
  have aux2:(forall i j, i <c j -> j <c p -> (Vf f i ) <c (Vf f j )).
    move=> i j ij jp.
    move: (ij) => [ij1 _].
    have isf: (inc i (source f))by rewrite sf /E1;apply/BintP =>//;co_tac.
    have jsf: (inc j (source f))by rewrite sf /E1;apply/BintP =>//;co_tac.
    have lij: glt r i j.
       move: ij => [ij nij]; rewrite /r; split=>//.
       apply / Bintco_gleP => //.
    move: sif => [ _ _ _ h]; move: (h _ _ lij) => [lVf nW].
    by split =>//; move: lVf; move /(Bintco_gleP npB) => [].
  split => //.
  move=> i /(BintP pB) h.
  by apply: (strict_increasing_prop1 pB aux aux2).
have Hi3:forall f, inc f Q2 ->
    lf_axiom (fun i => (Vf f i ) -c i) E1 E2.
  move=> f fQ2; move: (Hi0 _ fQ2) => [p1 p2 p3].
  move: (strict_increasing_prop2 pB p1 p2) => p4.
  have p5: (forall i, i <c p-> (Vf f i ) <c (n +c p)).
    move=> i ip.
    move: fQ2 => / HQ2P [[ff sf tf] vf].
    have : (inc (Vf f i) E3).
      by rewrite -tf; Wtac; rewrite sf;apply/ (BintP pB).
    by move /(BintP npB).
  move: (strict_increasing_prop3 pB nB p1 p2 p5) => p6.
  by move=> i /(BintP pB) => ip; apply /(BintcP nB);apply: p6.
have Hi1:forall f, inc f Q2 -> inc (subi f) (functions E1 E2).
   move=> f fQ2;apply /fun_set_P; rewrite /subi; red;aw;split => //.
   by apply: lf_function; apply: Hi3.
have Hi2:forall f, inc f Q2 -> inc (subi f) Q1.
  move=> f fQ2; apply: Zo_i; first by rewrite - s1 - s2; apply: Hi1.
  move: (Hi3 _ fQ2) => ta.
  move: (Bintco_wor p) => [[or _] _].
  move: (Binto_wor \0 c n) => [[or' _] _].
  rewrite /subi;red; aw; split => //; first (split; aw).
    by apply: lf_function.
  move=> x y xy.
  have xsf: (inc x E1) by rewrite s1; order_tac.
  have ysf: (inc y E1) by rewrite s1; order_tac.
  move: (Hi0 _ fQ2) => [p1 p2 p3].
  move:(strict_increasing_prop2 pB p1 p2) => p4.
  have yp: y <c p by move: ysf; move /(BintP pB).
  have xy': x <=c y by move: xy => /(Bintco_gleP pB) [].
  by move: (p4 _ _ xy' yp); aw => xx; apply /Binto_gleP; split => //;apply: ta.
set (G:= Lf (fun f=> subi f) Q2 Q1).
have Hi4:function G by rewrite / G; apply: lf_function.
set (addi:= fun f => Lf (fun i=> (Vf f i ) +c i) E1 E3).
have pa:forall f, inc f (functions E1 E2) ->
    lf_axiom (fun i => (Vf f i ) +c i) E1 E3.
  move=> f /fun_set_P [ff sf tf] t tE1.
  have: (inc (Vf f t) E2) by Wtac.
  move: tE1 => /(BintP pB) p1 /(BintcP nB) p2.
  apply /(BintP npB); apply: csum_Mlelt =>//; Bnat_tac.
have pa2: (forall f, inc f (functions E1 E2) ->
    inc (addi f) (functions E1 E3)).
  move=> f fE; rewrite /addi; apply /fun_set_P;red;aw;split => //.
  by apply: lf_function; apply: pa.
have pa3: forall f, inc f Q1 -> inc (addi f) Q2.
  move=> f /Zo_P; rewrite - s1 - s2; move=>[fe1e2 incf].
  apply /HQ2P; move: (pa2 _ fe1e2) => /fun_set_P [fa sa ta]; split => //.
  red; rewrite /function_prop sa ta; split => //.
      by move: (Bintco_wor p) => [[or _] _].
    by move: (Bintco_wor np) => [[or _] _].
  move=> x y [xy nxy].
  have xe1: inc x E1 by rewrite s1; order_tac.
  have ye1: inc y E1 by rewrite s1; order_tac.
  move: (pa _ fe1e2) => ta1.
  rewrite /addi lf_V // lf_V //.
  move: incf => [_ _ _ h]; move: (h _ _ xy); rewrite /r'/r'' /glt.
  have zB: inc \0 c Bnat by fprops.
  move /Binto_gleP => [p1 p2 p3].
  have ltxy: x <c y.
    by split =>//; move: xy; move /(Bintco_gleP pB) => [].
  move: p1 => /(BintcP nB) => p1.
  move: p2 => /(BintcP nB) => p2.
  have: ( (Vf f x) +c x) <c ( (Vf f y) +c y).
     apply: csum_Mlelt =>//; try Bnat_tac; try apply: E1B =>//.
  move=> [p4 p5];split => //; apply /(Bintco_gleP npB); split => //.
   apply: csum_Mlelt => //.
  by move: ye1 => /(BintP pB).
set (F:= Lf (fun f=> (addi f)) Q1 Q2).
have ff: function F by rewrite /F;apply: lf_function.
have cGF: composable G F by rewrite /G/F; split => //; aw.
have cFG: composable F G by rewrite /G/F; split => //; aw.
have c1i: (compose G F = identity (source F)).
  apply: function_exten; aw; [fct_tac |apply: identity_f | | ].
     rewrite /G/F; aw.
  move => x xsf /=;rewrite identity_V //.
  move: xsf ;rewrite /F; rewrite {1} corresp_s => xQ1.
  have aQ2: inc (addi x) Q2 by apply: pa3.
  aw; rewrite /G; aw.
  rewrite /addi/subi.
  move: (xQ1) => /HQ1P [[fx sx tx] icx].
  apply: function_exten; aw =>//.
     apply: lf_function; apply: Hi3; apply: pa3 =>//.
  move: (Hi3 _ aQ2)=> ta2.
  move=> a aE1 /=; aw.
    apply: cdiff_pr1; last by apply: E1B.
    apply: E2B;rewrite -tx//; Wtac.
  apply: pa; apply /fun_set_P;split => //.
have c2i: (compose F G = identity (source G)).
  apply: function_exten.
  - fct_tac.
  - apply: identity_f.
  - rewrite /F/G; aw.
  - rewrite /F/G;aw.
  - rewrite /G; aw.
  - move=> x xQ2 /=;rewrite identity_V //.
    have qQ1: inc (subi x) Q1 by apply: Hi2.
    move: (xQ2) => /HQ2P [[fx sx tx] icx].
    aw;rewrite /F; aw; rewrite /addi/subi.
    apply: function_exten =>//.
    - apply: lf_function; apply: pa; apply: Hi1=> //.
    - symmetry;aw.
    - symmetry; aw.
    - move: (Hi3 _ xQ2) => ta3.
      move:(pa _ (Hi1 _ xQ2)) => ta2.
      aw; move => a aE1 /=; aw; apply: cdiff_rpr.
      by move: (proj33 (Hi0 _ xQ2)); apply.
move: (bijective_from_compose cGF cFG c1i c2i) =>[bF bG GF].
have : (equipotent Q1 Q2) by exists F; rewrite /F;split => //; aw .
move /card_eqP; move=> ->.
have r1: (cardinal (substrate (Bint_co np))) = np.
   by rewrite (proj2 (Bintco_wor _)) card_Bint.
have r2: (cardinal (substrate (Bint_co p))) = p.
  by rewrite (proj2 (Bintco_wor _)) card_Bint.
rewrite /Q2 /r/r'' cardinal_set_of_increasing_functions /finite_set.
- rewrite r1 r2 //.
- apply: worder_total; apply: (proj1 (Bintco_wor _)).
- apply: worder_total; apply: (proj1 (Bintco_wor _)).
- by rewrite r2; fprops.
- by rewrite r1; fprops.
Qed.

Lemma increasing_compose f g r r' r'':
  increasing_fun f r r' -> increasing_fun g r' r'' ->
  [/\ g \coP f,
    (forall x, inc x (source f) -> Vf (g \co f) x = Vf g (Vf f x))
    & increasing_fun (g \co f) r r''].
Proof.
move=> [or or' [ff sf tf] icf][_ or'' [fg sg tg] icg].
have cgf: ( g \coP f) by split => //; ue.
have p:(forall x, inc x (source f) -> Vf (g \co f) x = Vf g (Vf f x)).
  move=> x xsf; aw.
split => //; split => //; first by split;aw; fct_tac.
move => x y xy.
   have xsf: inc x (source f) by rewrite sf; order_tac.
   have ysf: inc y (source f) by rewrite sf; order_tac.
by rewrite p // p //; apply: icg; apply: icf.
Qed.

Lemma increasing_compose3 f g h r r' r'' r''':
  strict_increasing_fun f r r' -> increasing_fun g r' r'' ->
  strict_increasing_fun h r'' r''' ->
  let res:= (h \co g ) \co f in
    [/\ inc res (functions (source f) (target h)),
      (forall x, inc x (source f) -> Vf res x = Vf h (Vf g(Vf f x))) &
      increasing_fun res r r'''].
Proof.
move=> sif ig sih.
move: (strict_increasing_w sif) => icf.
move: (strict_increasing_w sih) => ich.
move: (increasing_compose ig ich)=> [chg Whg igh].
move: (increasing_compose icf igh)=> [chgf Whgf ighf].
move=> res; rewrite /res;split => //.
  apply /fun_set_P; split => //; aw; fct_tac.
move=> x xsf; aw.
move: (increasing_compose icf ig) => [[_ ff sgtf] _ _];Wtac.
Qed.

Lemma cardinal_set_of_increasing_functions4 r r':
  let n := (cardinal (substrate r')) in
    let p := (cardinal (substrate r)) in
      total_order r -> total_order r' ->
      finite_set (substrate r) -> finite_set (substrate r') ->
      cardinal (functions_incr r r')
      = binom ((n +c p ) -c \1 c) p.
Proof.
move=> n p tor tor' fsr fsr'.
have nB: inc n Bnat by move: fsr' => /BnatP.
have pB: inc p Bnat by move: fsr => /BnatP.
have or: order r by move: tor => [tor _ ].
have or': order r' by move: tor' => [tor' _ ].
case: (equal_or_not n \0 c) => nz.
  rewrite nz; aw; fprops.
  have qe: substrate r'= emptyset by apply: cardinal_nonemptyset; rewrite-nz//.
  rewrite /functions_incr qe.
  case: (equal_or_not p \0 c) => pz.
    rewrite pz cdiff_wrong;fprops.
    rewrite binom00.
    have qe': substrate r = emptyset.
      by apply: cardinal_nonemptyset; rewrite -pz//.
    rewrite qe'; set qq:=Zo _ _.
    suff: singletonp qq by move => [x ->]; rewrite cardinal_set1.
    apply /singletonP; split.
       exists empty_function.
       move:empty_function_function => xx.
       apply : Zo_i; first by apply /fun_set_P.
       red; rewrite qe qe'; split => // a b gab.
       have: (inc a (substrate r)) by order_tac.
       by rewrite qe'; move=> /in_set0 ae.
    move => a b /Zo_P [pa _] /Zo_P [pb _].
    apply: ( fun_set_small_source pa pb).
  move: (cpred_pr pB pz) => [ppB sp].
  have ->: (p -c card_one = cpred p) by rewrite cpred_pr4 //; fprops.
  have ltp: (cpred p) <c p by rewrite {2} sp; fprops.
  rewrite binom_bad //.
  set qq:=Zo _ _ ; case: (emptyset_dichot qq).
    by move=> ->; apply: cardinal_set0.
  move=> [t tq]; move: tq => /Zo_P [] /fun_set_P [ft st tt] _.
  case: (emptyset_dichot (substrate r)) => h.
    by case: pz; rewrite /p h cardinal_set0.
  move: h=> [x xsr]; rewrite - st in xsr; move: (Vf_target ft xsr).
  by rewrite tt=> /in_set0.
move: (cpred_pr nB nz) => [pnB sn].
set q := (cpred n) in sn pnB.
have ->: ( (n +c p) -c \1 c = q +c p).
  rewrite sn; apply: (cdiff_pr2 (BS_sum pnB pB) BS1).
  rewrite (csum_via_succ1 _ pnB) Bsucc_rw; fprops.
move: (finite_ordered_interval1 tor fsr) => [f [isf _]].
move: (finite_ordered_interval1 tor' fsr') => [g [isg _]].
move: (inverse_order_is isf)=> isif.
move: (inverse_order_is isg)=> isig.
rewrite- (cardinal_set_of_increasing_functions3 pnB pB).
rewrite -/n in isg; rewrite -/p in isf isif.
have ->: Bint_cco \0 c q = Bint_co n.
  by rewrite /Bint_co/Bint_cco sn - Bint_co_cc /Bintcc.
set Q1:= functions_incr _ _.
set Q2:= functions_incr _ _.
set f' := inverse_fun f.
set g' := inverse_fun g.
set ff:= Lf (fun z => ((g \co z )) \co f') Q1 Q2.
have b_g: (bijection g) by move : isg=> [_ _ [ok _ _] _].
have i_g: (injection g) by exact (proj1 b_g).
have fg:function g by fct_tac.
have fif:function f' by move: isif => [_ _ [bg _ _] _]; fct_tac.
move: (order_isomorphism_increasing isg) => sig.
move: (order_isomorphism_increasing isif) => siif.
have tg: (substrate (Bint_co n) = target g).
  by move: sig => [_ _ [_ _ tg] _].
have soif : (substrate (Bint_co p) = source f')
  by move: siif => [_ _ [_ sf _] _].
have tf': (substrate r = target f') by move: siif => [_ _ [_ _ xx] _].
have sg : (substrate r' = source g) by move: sig => [_ _ [_ xx _]_].
have ta1:lf_axiom (fun z => (g \co z ) \co f') Q1 Q2.
  move=> z /Zo_P [zs iz].
  move: (increasing_compose3 siif iz sig) => [p1 p2 p3].
  apply: Zo_i => //; rewrite tg soif //.
have ffc3: (forall w, inc w Q1 -> Vf (compose3function f' g) w
    = (g \co w ) \co f').
  move => w wQ; move: (wQ) => /Zo_P [] /fun_set_P [fw sw tw] siw.
  rewrite c3f_V //; ue.
have s_f: (surjection f') by move : isif=> [_ _ [[_ ok] _ _]].
have s3: sub Q1 (source (compose3function f' g)).
  rewrite /compose3function /Q1 /functions_incr -tf' - sg.
  aw; apply: Zo_S.
apply /card_eqP.
exists ff; rewrite /ff; red;aw;split => //; apply: lf_bijective => //.
  move=> u v u1 v1;rewrite -(ffc3 _ u1) -(ffc3 _ v1).
  by move: (c3f_fi s_f i_g) => [_ h]; apply: h;apply: s3.
move=> y yQ2.
move: (isig) => [_ _ [qa qb qc] _].
have fg': function g' by fct_tac.
have b_f: (bijection f) by move : isf=> [_ _ [bg _ _]_].
have fif':function f by fct_tac.
move: (order_isomorphism_increasing isig) => sig'.
move: (order_isomorphism_increasing isf) => siif'.
move: (siif') => [_ _ [qa' qb' qc'] _].
have soig' :(substrate (Bint_co n) = source g') by rewrite qb.
set x := compose (compose g' y) f.
have xQ1: inc x Q1.
  move: yQ2=> /Zo_P [zs iz].
  move: (increasing_compose3 siif' iz sig'); simpl; move=> [p1 p2 p3].
  by apply: Zo_i => //; rewrite - qc -qb'.
ex_tac.
move: yQ2 => /Zo_P [] /fun_set_P [fy sy ty] _.
have c1: g' \coP y by split => //; ue.
have sysf: source y = target f by ue.
have c2: y \coP f by split => //; ue.
have fyg: function (y \co f) by fct_tac.
have tyg: target g = target (y \co f) by aw; ue.
have c4: g' \coP (y \co f) by split => //; aw; ue.
rewrite /x - (compfA c1 c2).
rewrite (compfA (composable_f_inv b_g) c4).
rewrite (bij_right_inverse b_g) tyg (compf_id_l fyg).
rewrite /f' -(compfA c2 (composable_f_inv b_f)) (bij_right_inverse b_f).
by rewrite - sysf (compf_id_r fy).
Qed.

Lemma binom_2plus n: inc n Bnat ->
  binom (succ n) \2 c = (n *c (succ n )) %/c \2 c.
Proof. move=> nB;rewrite binom2//. Qed.

Lemma binom_2plus0 n: inc n Bnat ->
  binom (succ n) \2 c = (binom n \2 c ) +c n.
Proof.
move=> nB.
have oB: inc card_one Bnat by fprops.
by rewrite - succ_one (binomSnSm nB oB) (binom1 nB).
Qed.

Lemma cardinal_pairs_lt n: inc n Bnat ->
  cardinal (Zo (coarse Bnat)
    (fun z => [/\ \1 c <=c (P z ), (P z ) <c (Q z ) & (Q z ) <=c n])) =
  (binom n \2 c ).
Proof.
move=> nB; rewrite /coarse.
set (E:= Bint1c n).
set T:=Zo _ _.
move: BS1 BS2 => oB tB.
case: (p_or_not_p (card_two <=c n)); last first.
  case: (card_le_to_el CS2 (CS_Bnat nB)).
    by move=> h h'; contradiction.
  move=> h _; rewrite binom_bad //; try apply: inc2_Bnat.
  case: (emptyset_dichot T); first by move=> ->; rewrite cardinal_set0.
  move=> [p pT]; move: pT => /Zo_P [a1 [a2 a3 a4]].
  have : (Q p) <c card_two by co_tac.
  rewrite - succ_one; move /(card_lt_succ_leP BS1) => a5.
  have a6: (P p) <c card_one by co_tac.
  co_tac.
move=> le2n.
have cE: cardinal E = n by rewrite card_Bint1c.
rewrite (subsets_with_p_elements_pr nB tB cE).
apply card_eqP.
exists (Lf (fun z=> (doubleton (P z) (Q z))) T
    (subsets_with_p_elements card_two E)).
split => //; aw; apply: lf_bijective.
    move=> z /Zo_P [zp [le1p [lepq npq] leqn]].
     have pE: inc (P z) E by apply /Bint_ccP1 => //; split => //;co_tac.
     have qE: inc (Q z) E by apply /Bint_ccP1 => //;split => //; co_tac.
    apply: Zo_i; last by apply: cardinal_set2.
    by apply /setP_P; apply: sub_set2.
move=> u v /Zo_P [] /setX_P [pu _ _] [_ lt1 _]
     /Zo_P [] /setX_P [pv _ _] [_ lt2 _] h.
  case: (doubleton_inj h); move=> [e1 e2].
    apply: pair_exten =>//.
    move: lt1;rewrite e1 e2; move => [lt1 _]; co_tac.
move => y /Zo_P [] /setP_P yE cy2.
have yB: sub y Bnat.
  apply: (@sub_trans E) => //; apply: Bint_S.
have [a [b [p1 p2]]]: exists a, exists b, a <c b /\ doubleton a b = y.
  move: (set_of_card_two cy2)=> [a [b [ab yab]]].
  have aE: inc a Bnat by apply: yB; rewrite yab; fprops.
  have bE: inc b Bnat by apply: yB; rewrite yab; fprops.
  case: (card_le_to_el (CS_Bnat aE)(CS_Bnat bE)).
    move=> h; exists a; exists b; split => //; split=>//.
  by move=> h; exists b; exists a;split => //; rewrite set2_C.
exists (J a b); aw => //.
apply: Zo_i.
  have aE: inc a Bnat by apply: yB; rewrite -p2; fprops.
  have bE: inc b Bnat by apply: yB; rewrite -p2; fprops.
  aw; fprops.
have: inc a E by apply: yE; rewrite -p2; fprops.
have: inc b E by apply: yE; rewrite -p2; fprops.
by aw; move /(Bint_ccP1 BS1 nB) => [pa pb] /(Bint_ccP1 BS1 nB) [pc pd].
Qed.

Lemma cardinal_pairs_le n: inc n Bnat ->
  cardinal(Zo (coarse Bnat)
    (fun z=> [/\ \1 c <=c (P z ), (P z ) <=c (Q z ) & (Q z ) <=c n])) =
     (binom (succ n) \2 c ).
Proof.
move=> nB.
rewrite (binom_2plus0 nB).
rewrite - cardinal_pairs_lt // /coarse.
set E1 := Zo _ _; set E2 := Zo _ _.
have s21: sub E2 E1.
  move=> t /Zo_P [pa [pb [pc _] pd]]; apply: Zo_i => //.
rewrite -(cardinal_setC s21).
suff: (E1 -c E2 = n) by move => ->.
set (T:= Bintcc card_one n).
have ->: n = cardinal T by rewrite card_Bint1c.
rewrite /card_diff; apply /card_eqP.
exists (Lf P (E1 -s E2) T); red;aw; split => //.
have cp: forall x, inc x (E1 -s E2) -> P x = Q x.
  move=> x /setC_P [] /Zo_P [xp [le1 le2 ne]] h.
  ex_middle npq; case: h; apply: Zo_i => //.
apply: lf_bijective.
    move=> x xc; move: (cp _ xc).
    move: xc => /setC_P [] /Zo_P [xp [le1 le2 le]] ns h.
    apply /(Bint_ccP1 BS1 nB); split => //; ue.
  move => u v uc vc; move: (cp _ vc) (cp _ uc) => h1 h2.
  move: uc vc => /setC_P [] /Zo_P [] /setX_P [pu _ _] _ _
       /setC_P [] /Zo_P [] /setX_P [pv _ _] _ _ sp.
   by apply: pair_exten => //; rewrite - h1 -h2 sp.
move=> y => /(Bint_ccP1 BS1 nB) [l1y lyn].
have yB: inc y Bnat by Bnat_tac.
exists (J y y); aw => //; apply /setC_P; split.
  apply: Zo_i; [ fprops | aw;split;fprops].
by move /Zo_hi => [_ bad _]; case: bad; aw.
Qed.

Lemma sum_of_i n: inc n Bnat ->
  card_sumb (Bint n) id = binom n \2 c.
Proof.
move: n; apply: cardinal_c_induction.
  rewrite binom_bad; fprops.
  rewrite /card_sumb csum_trivial =>//; bw; apply: Bint_co00.
  apply: card_lt_02.
move=> n nB hr.
have aux: forall a, inc a Bnat -> cardinalp a by move=> a aB; fprops.
rewrite -induction_on_sum // hr binom_2plus0 //.
Qed.

Lemma fct_sum_const1 f n m:
  inc n Bnat -> (forall i, i <c n -> f i = m) ->
  card_sumb (Bint n) f = n *c m.
Proof.
move=> nB p; rewrite /card_sumb.
have <-: (cst_graph (Bint n) m = Lg (Bint n) f).
   rewrite /cst_graph; apply: Lg_exten.
   by move=> x => /(BintP nB) => h; symmetry; apply: p.
rewrite csum_of_same cprodC.
apply: cprod2_pr2=>//.
rewrite card_Bint //;symmetry;apply: card_card; fprops.
Qed.

Lemma sum_of_i3 n: inc n Bnat ->
  card_sumb (Bint n) id = binom n \2 c.
Proof.
move=> nB; rewrite /card_sumb.
move: card_lt_02 => lt20.
case: (equal_or_not n \0 c) => nz.
  rewrite nz csum_trivial ? binom_bad; fprops.
  bw; apply: Bint_co00.
move: (cpred_pr nB nz) => [pB nsp].
rewrite nsp binom2 //.
set p := cpred n in pB nsp |- *.
set sn:= card_sum _ .
set aux:= (p *c (succ p)).
suff: (sn +c sn = aux).
  move => h.
  have aB: inc aux Bnat by rewrite /aux; fprops.
  have iB: inc sn Bnat.
    have cn: cardinalp sn by rewrite /sn/card_sum; fprops.
    rewrite -h in aB; apply: (Bnat_in_sum cn aB).
  rewrite - two_times_n in h.
  apply: (cdivides_pr2 aB BS2 iB card2_nz (sym_equal h)).
move: (sum_of_sums (fun i => i) (fun i=> (p -c i))
     (Bint (succ p))).
rewrite nsp in nB.
have fim: (forall i : Set, i <c (succ p) ->
  (fun i : Set => i +c (p -ci )) i = p).
  move=> i /(card_lt_succ_leP pB) => ilp.
  apply: cdiff_pr =>//; Bnat_tac.
rewrite (fct_sum_const1 nB fim).
rewrite cprodC /aux; move => <-; apply: f_equal.
rewrite /sn - /(card_sumb _ _) fct_sum_rev //.
Qed.

Lemma sum_of_i2 n: inc n Bnat ->
  card_sumb (Bintcc \1 c n) id =
  (binom (succ n) \2 c ).
Proof.
move => nB.
move: (sum_of_i3 (BS_succ nB)).
rewrite - (Bint_co_cc nB).
move: (Bint_pr5 nB) => [<- pb].
rewrite csumA_setU1 //; aw; rewrite /card_sumb /card_sum; fprops.
Qed.

Lemma sum_of_i2bis n: inc n Bnat ->
  card_sumb (Bintcc \1 c n) id = (binom (succ n) \2 c ).
Proof.
move => nB.
rewrite - cardinal_pairs_le //.
set (E:= Bintcc card_one n).
move: BS1 => oB.
set X:=Zo _ _ .
set(f:= Lg E (fun k => Zo X (fun z => Q z = k))).
have p1: X = unionb f.
  rewrite /f; set_extens x.
    move => xX; move/Zo_P: (xX) => [xs [le1 le2 le3]]; apply /setUb_P; bw.
    have qE:inc (Q x) E by apply /(Bint_ccP1 BS1 nB); split => //; co_tac.
    by ex_tac; bw; apply: Zo_i.
  by move=> /setUb_P; bw; move => [y yE]; bw; move /Zo_P => [].
have p2: f= disjointU_fam (Lg E (fun i => Bintcc card_one i)).
  rewrite /f /disjointU_fam; bw; apply: Lg_exten.
  move=> x xE; move: (xE)=> /(Bint_ccP1 BS1 nB) [ox xn].
  have xB: inc x Bnat by Bnat_tac.
  bw; set_extens t.
    move => /Zo_P [] /Zo_P [] /setX_P [pt _ qB] [oP pq _] qt.
     apply /indexed_P;split => //; apply /(Bint_ccP1 BS1 xB); split => //; ue.
  move /indexed_P => [pt] /(Bint_ccP1 BS1 xB) [pa pb] pc.
  apply: Zo_i => //; apply /Zo_P; rewrite pc.
  split => //; apply /setX_P; rewrite pc.
  split => //; Bnat_tac.
have ->: X = disjointU (Lg E (fun i => Bintcc card_one i)).
  by rewrite p1 p2 /disjointU.
apply /card_eqP; apply: equipotent_disjointU1.
split;fprops; bw => i iE; bw.
move: iE => /(Bint_ccP1 BS1 nB) [_ lin].
have iB: inc i Bnat by Bnat_tac.
apply /card_eqP; rewrite card_Bint1c //.
apply: card_card; fprops.
Qed.

number of monomials

Lemma sof_sum_eq_equi F n: inc n Bnat ->
   (functions_sum_eq F n ) \Eq (graphs_sum_eq F n ).
Proof.
move=> nB.
exists (Lf graph (functions_sum_eq F n) (graphs_sum_eq F n)).
red;aw; split => //; apply: lf_bijective.
    move => t ts; apply /funI_P; ex_tac.
  move=> u v /Zo_S /fun_set_P [fu su tu] /Zo_S /fun_set_P [fv sv tv] ge.
  apply: function_exten3 =>//; try ue.
by move=> y /funI_P.
Qed.

Lemma sof_sum_le_equi F n: inc n Bnat ->
  (functions_sum_le F n ) \Eq (graphs_sum_le F n ).
Proof.
move=> nB.
exists (Lf graph (functions_sum_le F n) (graphs_sum_le F n)).
red;aw; split => //;apply: lf_bijective.
    move => t ts; apply /funI_P; ex_tac.
  move=> u v /Zo_S /fun_set_P [fu su tu] /Zo_S /fun_set_P
     [fv sv tv] ge.
  apply: function_exten3 =>//; try ue.
by move=> y /funI_P.
Qed.

Lemma set_of_functions_sum0 f:
  (forall a, inc a Bnat -> f \0 c a = \1 c) ->
  (forall a, inc a Bnat -> f a \0 c = \1 c) ->
  (forall a b, inc a Bnat -> inc b Bnat ->
     f (succ a) (succ b) = (f (succ a) b ) +c (f a (succ b))) ->
  forall a b, inc a Bnat -> inc b Bnat -> f a b = (binom (a +c b) a ).
Proof.
move=> p2 p3 p4.
move=> a b aB bB; move: a aB b bB.
apply: cardinal_c_induction.
  move=> b bB; rewrite p2; aw; [ rewrite binom0 =>// | fprops].
move=> n nB fnb b bB.
rewrite (csum_via_succ1 _ nB).
move: b bB; apply: cardinal_c_induction.
  have snB: inc (succ n) Bnat by fprops.
  by rewrite (bsum0r nB) (binom_nn snB) (p3 _ snB).
move=> c cB fsn.
have sc: inc (succ c) Bnat by fprops.
rewrite (p4 _ _ nB cB) (fnb _ sc) fsn.
by rewrite - (csum_via_succ _ cB) (binomSnSm (BS_sum nB sc) nB).
Qed.

Lemma CS_card_sum f: cardinalp (card_sum f).
Proof. rewrite /card_sum; fprops. Qed.

Lemma CS_card_prod f: cardinalp (card_prod f).
Proof. rewrite /card_prod; fprops. Qed.

Hint Resolve CS_card_sum CS_card_prod: fprops.

Lemma set_of_functions_sum1 E x n:
  inc n Bnat -> ~ (inc x E ) ->
  (graphs_sum_le E n ) \Eq (graphs_sum_eq (E +s1 x) n ).
Proof.
move=> nB nxE.
set (K:= Bintc n).
set (f:= fun z=> z +s1 (J x (n -c (card_sum z )))).
exists (Lf f (graphs_sum_le E n)
    (graphs_sum_eq (E +s1 x) n)).
red;aw; split => //; apply: lf_bijective.
    move => z /(setof_suml_auxP _ nB) [dz lez fgz alc].
    apply /(setof_sume_auxP _ nB).
    have p0: (fgraph (f z)) by apply: fgraph_setU1 => //; ue.
    have p1: (E +s1 x) = domain (f z) by rewrite -dz domain_setU1 //.
    have xd: inc x (domain (f z)) by rewrite -p1; fprops.
    have Vx2: Vg (f z) x = (n -c (card_sum z)).
      rewrite /f setU1_V_out //; ue.
    have p2: cardinal_fam (f z).
      rewrite -dz in nxE; hnf.
      rewrite -p1; move=> i /setU1_P; case.
          rewrite -dz => idz; rewrite /f setU1_V_in //; apply: alc=>//.
      move => ->; rewrite Vx2 /card_diff; fprops.
    split => //.
    rewrite - (Lg_recovers p0) -p1 -/(card_sumb _ _) csumA_setU1 //.
    rewrite -dz /card_sumb.
    have ->: (Lg (domain z) (Vg(f z))) = z.
        apply /fgraph_exten => //;bw; fprops => t tf; rewrite /f; bw.
        rewrite setU1_V_in => //; ue.
    by rewrite Vx2; apply:cardinal_setC1.
  move => u v /(setof_suml_auxP _ nB) [fu su tu _].
  move /(setof_suml_auxP _ nB) => [fv sv tv _].
  apply: extension_injective => //; ue.
move=> y /(setof_sume_auxP _ nB) [fy sy ty suy].
  have pa: fgraph (Lg E (Vg y)) by fprops.
  have pb: cardinal_fam (Lg E (Vg y)).
    hnf; bw => t tE; bw; apply: suy; rewrite fy; fprops.
  have pc : n = card_sum (Lg E (Vg y)) +c Vg y x.
    rewrite - sy -{1} (Lg_recovers ty) -/(card_sumb (domain y) _).
    by rewrite fy (csumA_setU1 _ nxE).
   have pd: Vg y x = n -c card_sum (Lg E (Vg y)).
     rewrite pc in nB.
     rewrite pc csumC cdiff_pr1 //.
   apply: (Bnat_in_sum _ nB); apply: suy; rewrite fy; fprops.
   apply: (Bnat_in_sum2 _ nB); fprops.
exists (Lg E (Vg y)).
    apply /(setof_suml_auxP _ nB); bw;split => //; rewrite pc.
  apply:csum_M0le; fprops.
symmetry; rewrite /f;apply: fgraph_exten; fprops.
  apply fgraph_setU1; fprops; bw.
by rewrite domain_setU1; bw.
rewrite domain_setU1; bw; move => t; case /setU1_P => te.
rewrite setU1_V_in //; bw.
rewrite te setU1_V_out //; bw.
Qed.

Lemma set_of_functions_sum2 E n: inc n Bnat ->
cardinal(graphs_sum_le E (succ n))
= (cardinal (graphs_sum_eq E (succ n)))
    +c (cardinal (graphs_sum_le E n)).
Proof.
move => nB.
have snB: inc (succ n) Bnat by fprops.
set A:= (graphs_sum_eq E (succ n)).
set B:= (graphs_sum_le E (succ n)).
set C:= (graphs_sum_le E n).
have di: disjoint A C.
  apply: disjoint_pr.
  move=> u; move /(setof_sume_auxP _ snB) => [_ pb _ _].
  move /(setof_suml_auxP _ nB) => [_].
  rewrite pb; move: (card_lt_succ nB) => qa qb; co_tac.
suff: B = A \cup C by move => ->; rewrite (csum2_pr5 di) csum2_pr2a csum2_pr2b.
set_extens t.
  move /(setof_suml_auxP _ snB) => [pa pb pc1 pc2]; apply /setU2_P.
  case: (equal_or_not (card_sum t) (succ n)) => h.
    left; apply /(setof_sume_auxP _ snB); split => //.
  right; apply /(setof_suml_auxP _ nB); split => //.
  by apply /(card_lt_succ_leP nB); split.
case /setU2_P.
   move /(setof_sume_auxP _ snB) => [pa pb pc1 pc2].
   apply /(setof_suml_auxP _ snB);split => //; rewrite pb; fprops.
move /(setof_suml_auxP _ nB) => [pa pb pc1 pc2].
apply /(setof_suml_auxP _ snB);split => //.
move: (card_le_succ nB)=> aux; co_tac.
Qed.

Lemma set_of_functions_sum3 E:
  cardinal (graphs_sum_le E \0 c) = \1 c.
Proof.
have zb: inc \0 c Bnat by fprops.
set w:= graphs_sum_le _ _.
suff ->: (w = singleton (Lg E (fun _ =>\0 c))) by apply: cardinal_set1.
apply: set1_pr.
  apply /(setof_suml_auxP _ zb); bw;split => //.
      rewrite csum_of_same cprodC cprod0r; fprops.
    fprops.
  hnf; bw => t ti; bw; fprops.
move => z zw.
move: (zw); rewrite /w/graphs_sum_le.
move /funI_P => [g] /Zo_S /fun_set_P [qa qb qc] qd.
move: zw => /(setof_suml_auxP _ zb) [pa pb pc pd].
apply: fgraph_exten; fprops; bw.
rewrite pa;move => i zi /=; bw.
rewrite -qb in zi.
move: (Vf_target qa zi); rewrite qc /Vf qd; move /(BintcP BS0).
apply: (card_le0).
Qed.

Lemma set_of_functions_sum4 n: inc n Bnat->
    cardinal (graphs_sum_le emptyset n) = \1 c.
Proof.
move=> nB.
suff: (graphs_sum_le emptyset n =singleton emptyset).
  by move=> ->;apply: cardinal_set1.
apply: set1_pr.
  apply /(setof_suml_auxP _ nB);split; [bw | | fprops | ].
        rewrite csum_trivial; fprops; bw.
    apply: fgraph_set0.
  by move => t;rewrite domain_set0 => /in_set0.
move => z/ (setof_suml_auxP _ nB) [g df _ _].
by apply /domain_set0_P.
Qed.

Lemma set_of_functions_sum_pr n h:
  inc n Bnat -> inc h Bnat ->
  let intv:= fun h => (Bint h) in
    let sle:= fun n h => graphs_sum_le (intv h) n in
      let seq := fun n h => graphs_sum_eq (intv h) n in
        let A:= fun n h => cardinal (sle n h) in
          let B:= fun n h => cardinal (seq n h) in
            (A n h = B n (succ h) /\ A n h = (binom (n +c h) n )).
Proof.
move=> nB hB intv sle seq A B.
have AB: forall a b, inc a Bnat -> inc b Bnat -> A a b = B a (succ b).
  move=> a b aB bB; rewrite /A /B /sle/seq; apply /card_eqP.
  move: (Bint_pr4 bB) => [p1 p2].
  rewrite /intv -p1; apply: (set_of_functions_sum1 aB p2).
split; first by apply: AB.
have Hv: forall a b, inc a Bnat -> inc b Bnat ->
  A (succ a) b = (B (succ a) b ) +c (A a b ).
  move=> a b aB bB; rewrite /A/B /sle /seq.
  by rewrite - (set_of_functions_sum2 (intv b) aB).
apply: set_of_functions_sum0.
- move=> a aB; rewrite /A/sle; apply: set_of_functions_sum3.
- move=> a aB;rewrite /A/sle.
  have ->: (intv \0 c = emptyset).
    by rewrite /intv;apply: Bint_co00.
  apply: set_of_functions_sum4 =>//.
- move=> a b aB bB.
  by rewrite (Hv _ _ aB (BS_succ bB)) -(AB _ _ (BS_succ aB) bB).
- exact.
- exact.
Qed.

Definition graphs_sum_le_int p n :=
  graphs_sum_le (Bintc p) n.

Definition functions_incr_int p n :=
  (Zo (functions (Bintc p) (Bintc n))
    (fun z => increasing_fun z
      (Bint_cco \0 c p)
      (Bint_cco \0 c n))).

Lemma card_set_of_increasing_functions_int p n:
  inc p Bnat -> inc n Bnat ->
  cardinal (functions_incr_int p n) =
  binom (succ (n +c p)) (succ p).
Proof.
move=> pB nB.
have spB: inc (succ p) Bnat by fprops.
rewrite -(csum_via_succ _ pB).
rewrite - (cardinal_set_of_increasing_functions3 nB spB).
rewrite /functions_incr_int /functions_incr.
have zB: inc \0 c Bnat by fprops.
rewrite (proj2 (Bintco_wor _)) (proj2 (Binto_wor _ _)) - Bint_co_cc //.
have-> //: (Bint_co (succ p) = (Bint_cco \0 c p)).
move: (Bint_co_cc pB).
rewrite /Bint_cco /Bintc /Bintcc => -> //.
Qed.

Lemma double_restrc f n p: fgraph f -> inc p Bnat ->
  n <c p ->
  domain f = Bintc p ->
  restr (restr f (Bintc (succ n)))
     (Bintc n) =
     restr f (Bintc n).
Proof.
move=> fgf pB ltnp df.
have nB: inc n Bnat by move: ltnp=> [h _]; Bnat_tac.
rewrite double_restr //; apply: Bintc_M; fprops.
Qed.

Lemma induction_on_sum3 f m:
  fgraph f -> inc m Bnat ->
  domain f = Bintc m ->
  (forall a, inc a (domain f) -> cardinalp (Vg f a)) ->
  (card_sum (restr f (Bintc \0 c))= (Vg f \0 c )
    /\ (forall n, n <=c m ->
      (card_sum (restr f (Bint n))) +c (Vg f n )
      = card_sum (restr f (Bint (succ n))))).
Proof.
move=> fgf mB df alc.
split.
  rewrite Bint_cc00.
  have zd: (inc \0 c (domain f)) by rewrite df BintcP; fprops.
  rewrite csum_trivial4 card_card =>//; apply: alc =>//.
move=> n lenm.
have nB: inc n Bnat by Bnat_tac.
move: (Bint_pr4 nB) => [pa pb].
have qb: sub (Bint (succ n)) (domain f).
  by rewrite df - (Bint_co_cc nB); apply: Bintc_M.
have qa: sub (Bint n) (domain f).
  by apply: sub_trans qb; apply: Bint_M.
move: (csumA_setU1 (fun z => Vg f z) pb).
rewrite /card_sumb pa csumC //.
Qed.

Definition csum_to_increasing_fun y :=
  fun i => card_sum (restr y (Bintc i)).

Definition csum_to_increasing_fct y n p :=
  Lf (csum_to_increasing_fun y)
  (Bintc p) (Bintc n).

Lemma csum_to_increasing1 y n p:
  inc n Bnat -> inc p Bnat ->
  inc y (graphs_sum_le_int p n) ->
  lf_axiom (csum_to_increasing_fun y)
    (Bintc p)
    (Bintc n).
Proof.
move=> nB pB /(setof_suml_auxP _ nB) [dy dyxx les alc] u.
move /(BintcP pB) => up.
have sj:(sub (Bintc u) (domain y)).
  by rewrite dy; apply: Bintc_M.
move: (csum_increasing1 alc sj) => aux.
apply /(BintcP nB); co_tac.
Qed.

Lemma csum_to_increasing2 n p:
  inc n Bnat -> inc p Bnat ->
  lf_axiom (fun y=> (csum_to_increasing_fct y n p))
  (graphs_sum_le_int p n)
  (functions_incr_int p n).
Proof.
move=> nB pB y ys.
move: (csum_to_increasing1 nB pB ys) => ta1.
rewrite /csum_to_increasing_fct.
have aa: (forall u, inc u (domain y)-> inc (Vg y u) (Bintc n)).
  move: ys => /funI_P [z] /Zo_S /fun_set_P [fz sz tg] hz udy.
  rewrite hz -tg; aw; move=> h; apply: Vf_target =>//.
move: ys => /(setof_suml_auxP _ nB) [dy fhy les alc].
have ab: (forall u, inc u (domain y) -> inc (Vg y u) Bnat).
  move=> u udy; apply: (Bint_S (aa _ udy)).
set g:= Lf _ _ _ .
have p1: function g by apply: lf_function.
apply: Zo_i; first by apply /fun_set_P; split => //; rewrite /g;aw.
have zB: inc \0 c Bnat by fprops.
move: (Binto_wor \0 c p) => [[ok1 _ ] sr1].
move: (Binto_wor \0 c n) => [[ok2 _ ] sr2].
split => //; rewrite /g;aw; first by split; aw; try ue.
move=> a b; move /Binto_gleP => [asg bsg leab]; apply /Binto_gleP; aw.
split.
  have ag: inc a (source g) by rewrite /g; aw.
  move: (Vf_target p1 ag); rewrite /g; aw.
  have bg: inc b (source g) by rewrite /g; aw.
  move: (Vf_target p1 bg); rewrite /g; aw.
rewrite /csum_to_increasing_fun.
set f:= restr y (Bintc b).
have fgf: fgraph f by rewrite /f; fprops.
move: (asg)(bsg) => /(BintcP pB) lap /(BintcP pB) lbp.
have si: sub (Bintc b) (domain y).
  by rewrite dy; apply: Bintc_M.
have df: domain f = (Bintc b) by rewrite /f; bw.
have fc:(forall x, inc x (domain f) -> cardinalp (Vg f x)).
   move=> x; rewrite df; move=> xdf; rewrite /f; bw; apply: alc.
   apply: si=>//.
set j := (Bintc a).
have bB: inc b Bnat by Bnat_tac.
have sj: sub j (domain f) by rewrite /f df;apply: Bintc_M.
have -> : restr y j = restr f j by rewrite /f double_restr // -df //.
exact (csum_increasing1 fc sj).
Qed.

Lemma csum_to_increasing4 n p:
  inc n Bnat -> inc p Bnat ->
  injection (Lf (fun y=> (csum_to_increasing_fct y n p))
  (graphs_sum_le_int p n)
  (functions_incr_int p n)).
Proof.
move=> nB pB; apply: lf_injective.
  apply: csum_to_increasing2 =>//.
rewrite /csum_to_increasing_fct.
move=> u v us vs h.
move: (csum_to_increasing1 nB pB vs)=> ta2.
have aux: forall x, inc x (Bintc p) ->
  card_sum (restr u (Bintc x)) =
   card_sum (restr v (Bintc x)).
  move=> x xi; move: (f_equal (Vf ^~ x) h); aw.
  apply: csum_to_increasing1 =>//.
clear h.
move: us vs; rewrite /graphs_sum_le_int.
move /(setof_suml_auxP _ nB)=> [du lesu fgu alcu].
move /(setof_suml_auxP _ nB)=> [dv lesv fgv alcv].
apply: fgraph_exten =>//; first by ue.
move: (induction_on_sum3 fgu pB du alcu) => [u1 u2].
move: (induction_on_sum3 fgv pB dv alcv) => [v1 v2].
move=> x xdu.
case: (equal_or_not x \0 c)=> zx.
  rewrite zx -u1 -v1 aux =>//; apply /(BintcP pB); fprops.
have xlep: x <=c p by move: xdu; rewrite du; move /(BintcP pB).
have xB: inc x Bnat by rewrite du in xdu; apply: (Bint_S xdu).
move: (cpred_pr xB zx) => [prB xsp].
have i2:(Bint x = (Bintc (cpred x))).
  rewrite {1} xsp - Bint_co_cc //.
have xip: inc x (Bintc p) by ue.
have xpip: inc (cpred x) (Bintc p).
have psp: p <=c (succ p) by fprops.
   apply /(BintcP pB) /(card_le_succ_succP); fprops.
   rewrite -xsp; co_tac.
move: (u2 _ xlep)(v2 _ xlep); rewrite - Bint_co_cc // i2.
move: (ta2 _ xip); rewrite / csum_to_increasing_fun.
rewrite (aux _ xip) (aux _ xpip).
set A:= card_sum _; set B:= card_sum _.
move=> AB h1 h2; move: (Bint_S AB) => AB1.
apply: (@csum_simplifiable_left B) => //.
  have Bc: cardinalp B by rewrite /B /card_sum; fprops.
   rewrite -h1 in AB1;apply: (Bnat_in_sum2 Bc AB1).
  rewrite -h1 in AB1; apply: (Bnat_in_sum (alcu _ xdu) AB1).
  rewrite du -dv in xdu.
  rewrite -h2 in AB1; apply: (Bnat_in_sum (alcv _ xdu) AB1).
rewrite h1 h2//.
Qed.

Lemma csum_to_increasing5 n p:
  inc n Bnat -> inc p Bnat ->
  surjection (Lf (fun y=> (csum_to_increasing_fct y n p))
  (graphs_sum_le_int p n)
  (functions_incr_int p n)).
Proof.
move=> nB pB; apply: lf_surjective.
  apply: csum_to_increasing2 =>//.
move =>y /Zo_P [] /fun_set_P [fy sy ty] iy.
rewrite /graphs_sum_le_int /csum_to_increasing_fct.
set E1:= Bintc p in sy iy |- *.
set E2:= Bintc n in ty iy |- *.
have Hb:inc \0 c E1 by apply /(BintcP pB); fprops.
set (a:= Vf y \0 c).
have aE2: inc a E2 by rewrite -ty /a; Wtac.
have rec:(forall u, u <> \0 c -> inc u (source y) ->
    exists v, [/\ inc v (source y), u = succ v, v = cpred u &
       (Vf y v ) <=c (Vf y u )]).
  move=> u unz usy.
  have up: u <=c p by move: usy;rewrite sy; move/ (BintcP pB).
  have uB:inc u Bnat by Bnat_tac.
  move: (cpred_pr uB unz)=> [pn sp].
  have cp: cardinalp (cpred u) by fprops.
  move: (card_le_succ0 cp); rewrite - sp => lepu.
  have psy: (inc (cpred u) (source y)).
   rewrite sy; apply/ (BintcP pB); co_tac.
  have zB: inc \0 c Bnat by fprops.
  exists (cpred u); split=> //; move: iy => [o1 o2 [_ s1 s2] op].
  have ge1: gle (Bint_cco \0 c p) (cpred u) u.
    rewrite /E1 /Bintc in sy.
     apply/ (Binto_gleP); rewrite - sy;split => //.
  by move: (op _ _ ge1) => /(Binto_gleP) [_ []].
set (f:= fun i => Yo(i = \0 c) a ((Vf y i ) -c (Vf y (cpred i)))).
have f1p: (forall i, inc i E1 -> inc (f i) E2).
  move=> i i1; rewrite /f; Ytac h =>//.
  rewrite sy in rec; move: (rec _ h i1) => [v [vsy usv vp wle]].
  apply /(BintcP nB).
  rewrite - sy in i1 vsy.
  move : (Vf_target fy i1)(Vf_target fy vsy).
  rewrite ty ; move /(BintcP nB) => win /(BintcP nB) wvn.
  have wib: inc (Vf y i) Bnat by Bnat_tac.
  have wvb: inc (Vf y v) Bnat by Bnat_tac.
  move: (cdiff_le_symmetry wle) => h1; rewrite -vp; co_tac.
set (g:= Lg E1 f).
have fg: fgraph g by rewrite /g; fprops.
have dg: domain g = Bintc p by rewrite /g;bw.
have cg: forall a, inc a (domain g) -> cardinalp (Vg g a).
  rewrite /g; bw;move=> b bdg; rewrite /g; bw.
  move: (f1p _ bdg);rewrite /E2 => aux; move: (Bint_S aux) => wB.
  fprops.
move: (induction_on_sum3 fg pB dg cg)=> [g0 g1].
set (h:= fun i=> card_sum (restr g (Bintc i))).
have h0: (h \0 c = Vf y \0 c).
  rewrite /h g0 /g; bw; rewrite /f Y_true //.
have h1: forall i, inc i E1 -> h i = Vf y i.
  move=> i /(BintcP pB) => ip.
  apply: (cardinal_c_induction5 (r:=fun i=> h i = Vf y i) pB h0) =>//.
  move=> m mp; rewrite /h => hr.
  have mB: inc m Bnat by move: mp => [mp _]; Bnat_tac.
  have cm: cardinalp m by fprops.
  have smB: inc (succ m) Bnat by fprops.
  set (n1:= succ m).
  have n1p: (n1 <=c p) by apply /card_le_succ_ltP.
  move: (g1 _ n1p); rewrite /n1.
  rewrite - Bint_co_cc // - Bint_co_cc // hr; move=> <-.
  have snz: (succ m <> \0 c) by apply: succ_nz.
  have sm1: inc (succ m) E1 by apply /(BintcP pB).
  rewrite /g; bw; rewrite /f Y_false // cpred_pr1 //.
  have smsy: (inc (succ m) (source y)) by ue.
  move: (rec _ snz smsy) => [v [vsy smsv vp wle]].
  have mv: m = v.
    apply: succ_injective1; fprops.
    move: vsy; rewrite sy; move /(BintcP pB) => [aux _]; fprops.
  rewrite -mv in wle.
  move: (Vf_target fy smsy); rewrite ty /E2 => wi.
  move: (Bint_S wi)=> wsB.
  apply: cdiff_pr =>//; Bnat_tac.
have p1: inc g (graphs_sum_le E1 n).
  apply /(setof_suml_auxP _ nB); split => //.
  have pe1: inc p E1 by apply /(BintcP pB); fprops.
  move: (h1 _ pe1); rewrite /h -dg restr_to_domain; fprops.
  move => ->.
  rewrite - sy in pe1; move: (Vf_target fy pe1).
  by rewrite ty; move/(BintcP nB).
ex_tac.
move :(csum_to_increasing1 nB pB p1) => aux.
apply: function_exten => //; aw.
  apply: lf_function => //.
rewrite sy; move=> x xsy /=; aw;rewrite -h1 //.
Qed.

Lemma csum_to_increasing6 n p:
  inc p Bnat -> inc n Bnat ->
  cardinal (graphs_sum_le_int p n) =
  binom (succ (n +c p)) (succ p).
Proof.
move=> pB nB.
rewrite - card_set_of_increasing_functions_int //.
apply /card_eqP.
exists (Lf (fun y=> (csum_to_increasing_fct y n p))
    (graphs_sum_le_int p n)
    (functions_incr_int p n)).
red;aw; split => //.
by split; [apply: csum_to_increasing4 | apply: csum_to_increasing5].
Qed.

End IntegerProps.
Export IntegerProps.