(** * Theory of Sets EIII-5 Properties of integers Copyright INRIA (2009-2014) Apics; Marelle Team (Jose Grimm). *) (* $Id: sset9.v,v 1.160 2016/05/18 14:54:53 grimm Exp $ *) Require Import ssreflect ssrfun ssrbool eqtype ssrnat. Require Export sset8. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module IntegerProps. (** ** EIII-5-1 Operations on integers and finite sets*) (** Functions on nat *) Lemma Nsum_M0le a b: natp a -> a <=c (a +c b). Proof. by move=> /CS_nat ca; apply: csum_M0le. Qed. Lemma Nprod_M1le a b: natp a -> b <> \0c -> a <=c (a *c b). Proof. by move=> /CS_nat ca ; apply: cprod_M1le. Qed. Lemma NleT_ell a b: natp a -> natp b -> [\/ a = b, a aN bN; apply: cleT_ell; fprops. Qed. Lemma NleT_el a b: natp a -> natp b -> a <=c b \/ b aN bN; apply: cleT_el; fprops. Qed. Lemma NleT_ee a b: natp a -> natp b -> a <=c b \/ b <=c a. Proof. move=> aN bN; apply: cleT_ee; fprops. Qed. Lemma induction_sum0 f a b: (~ inc b a) -> csum (restr f (a +s1 b)) = csum (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) -> cprod (restr f (a +s1 b)) = (cprod (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) -> csum f = csum (restr f a) +c (Vg f b). Proof. by move=> df nba; rewrite - (induction_sum0 _ nba) -df - csum_gr. Qed. Lemma induction_prod1 f a b: domain f = a +s1 b -> (~ inc b a) -> cprod f = cprod (restr f a) *c (Vg f b). Proof. by move=> df nba; rewrite - (induction_prod0 _ nba) - df - cprod_gr. Qed. (** Definition of a finite family of integers *) Definition finite_int_fam f:= (allf f natp) /\ 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) -> natp (csum (restr f x)). Proof. move: fif => [alN fsd] sxd. have fsx:= (sub_finite_set sxd fsd). move: x fsx sxd; apply: finite_set_induction0. move=> _;rewrite csum_trivial; fprops; bw; fprops. move=> a b ap nba st;rewrite (induction_sum0 _ nba). apply: NS_sum; [apply: ap; apply: sub_trans st | ];fprops. Qed. Lemma finite_product_finite_aux x: sub x (domain f) -> natp (cprod (restr f x)). Proof. move: fif => [alN 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 =>//. apply:NS_prod;[apply: ap; apply: sub_trans st | ];fprops. Qed. Theorem finite_sum_finite: natp (csum f). Proof. rewrite - csum_gr;apply: finite_sum_finite_aux;fprops. Qed. Theorem finite_product_finite: natp (cprod f). Proof. rewrite - cprod_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. by hnf; rewrite /allf dg /g; split => //i idf; bw;apply /NatP; apply: alf. move: (csum_pr1 f) (finite_sum_finite fif) => f2 xN. by apply/card_finite_setP; apply: (NS_le_nat 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. hnf;rewrite cprod_pr; apply: Nat_hi. apply: finite_product_finite; split; last ue. by hnf; bw; move=> i idf; bw; apply /NatP;apply: alf. Qed. (** ** EIII-5-2 Strict inequalities between integers *) (** If a (a <> \0c <-> \0c aN; split; [ apply : card_ne0_pos; fprops | by case => _ /nesym]. Qed. Lemma strict_pos_P a: natp a -> (\0c <> a <-> \0c aN; split; [ move /nesym; apply:card_ne0_pos; fprops | by case ]. Qed. Lemma csum_M0lt a b: natp a -> b <> \0c -> a aN bnz. move: (cltS aN); rewrite - csum2cr (Nsucc_rw aN) => asa. apply: (clt_leT asa); apply: csum_Meqle; apply: cge1; fprops. by move/card_nonempty. Qed. Lemma card_ltP1 a b: natp b -> a exists c, [/\ natp c, c <> \0c & a +c c = b]. Proof. move=> bN [ab nab]; move: (NS_diff a bN) => pa; exists (b -c a); split => //. by apply: cdiff_nz. by rewrite (cdiff_pr ab). Qed. Theorem card_ltP a b: natp a -> natp b -> (a exists c, [/\ natp c, c <> \0c & a +c c = b]). Proof. move=> aN bN; split; first by apply:card_ltP1. move=> [c [cN cnz <-]] ;apply:csum_M0lt; fprops. Qed. (** Compatibility of sum and product with strict order *) Lemma csum_Meqlt a a' b: natp b -> a (b +c a) bN la; move:b bN; apply: Nat_induction. by rewrite (csum0l (proj31_1 la)) (csum0l (proj32_1 la)). by move => n nN hr; rewrite (csum_Sn _ nN) (csum_Sn _ nN);apply: cltSS. Qed. Lemma csum_Mlelt a b a' b': natp a' -> a <=c a' -> b (a +c b) a'N aa' bb'. exact: (cle_ltT (csum_Mleeq b aa') (csum_Meqlt a'N bb')). Qed. Lemma csum_Mlteq a a' b: natp b -> a (a +c b) bN aa'; rewrite csumC (csumC a' b); apply: csum_Meqlt. Qed. Lemma cprod_Meqlt a b b': natp a -> natp b' -> b a <> \0c -> (a *c b) aN b'N lt anz; move: (NS_lt_nat lt b'N) => bN. move: (card_ltP1 b'N lt) => [c [cN cnz <-]]. rewrite cprodDl; apply:(csum_M0lt (NS_prod aN bN) (cprod2_nz anz cnz)). Qed. Lemma cprod_Mlelt a b a' b': natp a' -> natp b' -> a <=c a' -> b a' <> \0c -> (a *c b) a'N b'N aa' bb' anz. apply: (cle_ltT (cprod_Mleeq b aa') (cprod_Meqlt a'N b'N bb' anz)). Qed. Lemma cprod_M1lt a b: natp a -> a <> \0c -> \1c a aN anz lt1b; move: a aN anz; apply: Nat_induction => //. move => n nN hrec _. rewrite cprodC (cprod_via_sum _ (CS_nat nN)) cprodC. case: (equal_or_not n \0c) => h. by rewrite h succ_zero cprod0l (csum0l (proj32_1 lt1b)). move: (csum_Mlteq NS1 (hrec h));rewrite -(Nsucc_rw nN) => h2. by apply:(clt_leT h2); apply:(csum_Meqle _ (proj1 lt1b)). 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) (csum f) [f2 f3] [g2 g3] df ale [i ifg lti]. have idg: inc i (domain g) by rewrite -df. move: (sym_eq (setC1_K ifg)) => dtc. have incd: ~ (inc i (complement (domain f) (singleton i))). by move=> /setC1_P [_ ]; aw. 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). apply: csum_Mlelt lti. by 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) card_nz_fam g -> (cprod f) [f2 f3] [g2 g3] df ale [i ifg lti] alne. have idg: inc i (domain g) by rewrite -df. have afN: natp (Vg f i) by apply: f2. have agN: natp (Vg g i) 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 =>//. + by apply: finite_product_finite_aux. + apply: cprod_increasing;fprops; bw; first by ue. move=> x xd; bw=>//; rewrite - ?df;fprops. + apply/cprod_nzP; fprops; hnf;rewrite restr_d. move=> j jdg; move: (jdg) => /setC1_P [jd _]; bw;apply: (alne _ jd). Qed. (** Compatibility of power and order *) Lemma cpow_nz a b: a <> \0c -> (a ^c b) <> \0c. Proof. move=> anz;rewrite - cpow_pr2; apply /cprod_nzP;hnf; bw => t tb; bw. Qed. Lemma cpow2_nz x: \2c ^c x <> \0c. Proof. apply: cpow_nz; fprops. Qed. Lemma cpow_Mltle a a' b: natp a' -> natp b -> a b <> \0c -> (a ^c b) a'N bN aa' nzb. move:b bN nzb; apply:Nat_induction => // n nN hrec _. case: (equal_or_not n \0c) => nz. by rewrite nz succ_zero (cpowx1 (proj31_1 aa')) (cpowx1 (proj32_1 aa')). rewrite (cpow_succ _ nN) (cpow_succ _ nN). apply:(cprod_Mlelt (NS_pow a'N nN) a'N (proj1 (hrec nz)) aa'). exact: (cpow_nz (card_gt_ne0 aa') (b:=n)). Qed. Lemma cpow_Meqlt a b b': natp a -> natp b' -> b \1c (a ^c b) aN b'N bb' l1a. have anz := card_gt_ne0 l1a. have bN:= NS_lt_nat bb' b'N. have [c [cN cnz <-]]:= (card_ltP1 b'N bb'). have le1 := (clt_leT l1a (cpow_Mle1 (CS_nat aN) cnz)). rewrite cpow_sum2; apply: cprod_M1lt;fprops; apply: (cpow_nz anz). Qed. Lemma cpow2_MeqltP n m: natp n -> natp m -> (\2c ^c n n sa sb; split => h; last apply: (cpow_Meqlt NS2 sb h clt_12). by case: (NleT_el sb sa) => // /cpow_M2le /(cltNge h). Qed. Lemma cpow_M1lt a b: cardinalp a -> \1c a ca /(cleSltP NS1); rewrite succ_one => h. apply: (clt_leT (cantor ca)); apply:(cpow_Mleeq _ h card2_nz). Qed. (** Injectivity of sum and product *) Section Simplifications. Variables (a b b' :Set). Hypotheses (aN: natp a) (bN: natp b) (b'N: natp b'). Lemma csum_eq2l: a +c b = a +c b' -> b = b'. Proof. move=> eql. case: (NleT_ell bN b'N) =>// aux. by case: (proj2 (csum_Meqlt aN aux)). by case: (proj2 (csum_Meqlt aN aux)). Qed. Lemma csum_eq2r: b +c a = b' +c a -> b = b'. Proof. by rewrite csumC (csumC b' a); apply: csum_eq2l. Qed. Lemma cprod_eq2l: a <> \0c -> a *c b = a *c b' -> b = b'. Proof. move=> naz eql. case: (NleT_ell bN b'N) =>// aux. by case: (proj2 (cprod_Meqlt aN b'N aux naz)). by case: (proj2(cprod_Meqlt aN bN aux naz)). Qed. Lemma cprod_eq2r: a <> \0c -> b *c a = b' *c a -> b = b'. Proof. by rewrite cprodC (cprodC b' a);apply: cprod_eq2l. Qed. End Simplifications. (** cardinal difference *) Lemma cdiff_rpr a b: b <=c a -> (a -c b) +c b = a. Proof. by move=> /cdiff_pr ;rewrite csumC. Qed. Lemma cdiff_pr2 a b c: natp a -> natp b -> a +c b = c -> c -c b = a. Proof. by move=> aN bN h; move: (cdiff_pr1 aN bN); rewrite h. Qed. Lemma cdiff_pr3 a b n: natp n -> a <=c b -> b <=c n -> (n -c b) <=c (n -c a). Proof. move => mN le1 le2. have bN:=(NS_le_nat le2 mN). have aN:=(NS_le_nat le1 bN). have dN:=(NS_sum (NS_diff a bN) (NS_diff b mN)). rewrite - {2} (cdiff_pr le2) -{2} (cdiff_pr le1). rewrite - csumA (csumC a) (cdiff_pr1 dN aN) csumC. apply:(csum_M0le _ (CS_diff n b)). Qed. Lemma cdiff_pr7 a b c: a <=c b -> b natp c -> (b -c a) le1 lt2 cN. have bN:= (NS_lt_nat lt2 cN). have aN:= (NS_le_nat le1 bN). move:(NS_diff a bN) (NS_diff b cN) => ha hb. rewrite -(cdiff_pr (proj1 lt2)) - {2}(cdiff_pr le1) - csumA csumC. rewrite (cdiff_pr1 (NS_sum ha hb) aN);apply: (csum_M0lt ha (cdiff_nz lt2)). Qed. Lemma cdiff_pr8 n p q: q <=c p -> p <=c n -> natp n -> (n -c p) +c q = n -c (p -c q). Proof. move => leqp lepn nN. have pN := NS_le_nat lepn nN. have qN := NS_le_nat leqp pN. rewrite - {2} (cdiff_pr lepn) -{2} (cdiff_pr leqp) [in RHS] csumC. by rewrite csumA (cdiff_pr1 (NS_sum (NS_diff p nN) qN) (NS_diff q pN)). Qed. Lemma cdiffA2 a b c: natp a -> natp b -> c <=c a -> (a +c b) -c c = (a -c c) +c b. Proof. move => aN bN h. move:(NS_sum (NS_diff c aN) bN) (NS_le_nat h aN) => pa pb. rewrite - {1} (cdiff_pr h) - csumA (csumC c) cdiff_pr1 //. Qed. Lemma cdiffSn a b: natp a -> b <=c a -> (csucc a) -c b = csucc (a -c b). Proof. move => aN leab. rewrite (Nsucc_rw aN) (Nsucc_rw (NS_diff b aN)); apply: (cdiffA2 aN NS1 leab). Qed. Lemma cardinal_setC4 E A: sub A E -> finite_set E -> cardinal (E -s A) = (cardinal E) -c (cardinal A). Proof. move => AE /NatP sN. have cc:= (cardinal_setC AE); rewrite - cc in sN. symmetry; rewrite - cc csumC;apply: cdiff_pr1. exact: (Nat_in_sumr (CS_cardinal (E -s A)) sN). exact:(Nat_in_suml (CS_cardinal A) sN). Qed. Lemma cdiff_nn a: a -c a = \0c. Proof. by rewrite /cdiff setC_v cardinal_set0. Qed. Lemma cdiff_0n n : \0c -c n = \0c. Proof. have h: (\0c -s n) = emptyset by apply/set0_P => t /setC_P [/in_set0]. by rewrite /cdiff h cardinal_set0. Qed. Lemma cdiff_pr4 a b a' b': natp a -> natp b -> natp a' -> natp b' -> a <=c b -> a' <=c b' -> (b +c b') -c (a +c a') = (b -c a) +c (b' -c a'). Proof. move=> aN bN a'N b'N ab a'b'. have aux: ((b -c a) +c b') +c a = b' +c b. by rewrite (csumC _ b') - csumA cdiff_rpr. apply: cdiff_pr2; fprops. by rewrite (csumC a a') csumA - (csumA _ _ a') (cdiff_rpr a'b') aux csumC. Qed. Lemma cdiffA a b c: natp a -> natp b -> natp c -> (b +c c) <=c a -> (a -c b) -c c = a -c (b +c c). Proof. move=> aN bN cN h. have aux:= (cdiff_pr h). 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 \1c. Proof. move=> ca. case: (Nat_dichot ca) => aN. case: (equal_or_not a \0c) => anz. rewrite anz cpred0 cdiff_wrong; fprops. move:(cpred_pr aN anz) => [sa {2} ->]. by rewrite (csucc_pr4 (CS_nat sa)) (cdiff_pr1 sa NS1). by rewrite (cpred_inf aN) (cdiff_fin_infin finite_1 aN). Qed. Lemma cpred_monotone a b: a <=c b -> cpred a <=c cpred b. Proof. move => [ca cb sab]; split; [exact (CS_pred ca) | exact (CS_pred cb) | ]. rewrite /cpred => t /setU_P [y ya /sab yb]; union_tac. Qed. Lemma cdiff_lt_pred a b: natp b -> b <> \0c -> (a a <=c (b -c \1c)). Proof. move => bN /(cpred_pr bN) [sa sb]. rewrite - (cpred_pr4 (CS_nat bN)) {1} sb;exact:(cltSleP sa). Qed. Lemma cdiff_nz1 a b: natp a -> natp b -> (csucc b) <=c a -> a -c b <> \0c. Proof. move=> aN bN lesba; apply: cdiff_nz => //; apply /cleSltP => //. Qed. Lemma cdiff_A1 a b: natp a -> natp b -> (csucc b) <=c a -> cpred (a -c b) = a -c (csucc b). Proof. move=> aN bN; rewrite (Nsucc_rw bN) => h'. rewrite - cdiffA; fprops; apply: cpred_pr4; fprops. Qed. Lemma cdiff_ab_le_a a b: cardinalp a -> (a -c b) <=c a. Proof. by move => ca; move: (sub_smaller (@sub_setC a b)); rewrite (card_card ca). Qed. Lemma cdiff_lt_symmetry' n p: natp p -> p <> \0c -> cpred (p -c n) pN pnz. exact: (cle_ltT (cpred_monotone (cdiff_le1 n (CS_nat pN))) (cpred_lt pN pnz)). Qed. Lemma cdiff_lt_symmetry n p: natp p -> n cpred (p -c n) pN ltnp; exact:(cdiff_lt_symmetry' n pN (card_gt_ne0 ltnp)). Qed. Lemma double_diff n p: natp n -> p <=c n -> n -c (n -c p) = p. Proof. move=> nN lepn. have pN:= (NS_le_nat lepn nN). exact: (cdiff_pr2 pN (NS_diff p nN) (cdiff_pr lepn)). Qed. Lemma csucc_diff a b: natp a -> natp b -> (csucc b) <=c a -> a -c b = csucc (a -c (csucc b)). Proof. move=> aN bN aux; move: (NS_succ bN) => sN. apply: cdiff_pr2; fprops. have dN: natp (a -c (csucc b)) by fprops. by rewrite (csum_Sn _ dN) - (csum_nS _ bN); apply: cdiff_rpr. Qed. Lemma cdiff_pr5 a b c: cardinalp a -> cardinalp b -> natp c -> (a +c c) -c (b +c c) = a -c b. Proof. move => ca cb cN;move: c cN; apply: Nat_induction; first aw. move => n nN Hrec; rewrite (csum_nS _ nN) (csum_nS _ nN) cdiff_succ //; fprops. Qed. Lemma cdiff_pr6 a b: natp a -> natp b -> (csucc a) -c (csucc b) = a -c b. Proof. by move => /CS_nat ca /CS_nat cb; apply:cdiff_succ. Qed. Lemma cprodBl a b c: natp a -> natp b -> natp c -> a *c (b -c c) = (a *c b) -c (a *c c). Proof. move=> aN bN cN. case: (NleT_ee bN cN) => le. by rewrite (cdiff_wrong le) (cdiff_wrong (cprod_Meqle a le)) (cprod0r). symmetry; apply: cdiff_pr2; fprops; rewrite - cprodDl csumC cdiff_pr //. Qed. Lemma cardinal_complement_image1 f (S := source f) (T := target f) : injection f -> (cardinal (T -s (Imf f))) +c (cardinal S) = cardinal T. Proof. move => injf. set A:= (Imf f). have ->: (cardinal S = cardinal A). apply /card_eqP;exists (restriction_to_image f). rewrite /restriction_to_image/restriction2; hnf;aw; split => //. by apply: (restriction_to_image_fb injf). symmetry; rewrite csumC. have p0: sub A T by apply: fun_image_Starget; fct_tac. rewrite - {1} (setU2_Cr p0) csum2cl csum2cr csum2_pr5 //;apply: set_I2Cr. Qed. Lemma cardinal_complement_image f (S := source f) (T := target f) : injection f -> finite_set T -> cardinal (T -s (Imf f)) = (cardinal T) -c (cardinal S). Proof. move=> injf /NatP fb. have h:= (cardinal_complement_image1 injf). rewrite - h in fb |- *. have aN := (Nat_in_sumr (CS_cardinal S) fb). have cN:= (Nat_in_suml (CS_cardinal (T -s Imf f)) fb). by symmetry;apply: cdiff_pr1. Qed. (* Properties of the Nat ordering *) Lemma NleR a: inc a Nat -> a <=N a. Proof. move => aN; split;fprops. Qed. Lemma NleT a b c: a <=N b -> b <=N c -> a <=N c. Proof. move /Nat_order_leP => ab /Nat_order_leP bc; apply /Nat_order_leP. move: Nat_order_wor=> [[or wor] _]; order_tac. Qed. Lemma NleA a b: a <=N b -> b <=N a -> a = b. Proof. move /Nat_order_leP => ab /Nat_order_leP ba. move: Nat_order_wor=> [[or wor] _]; order_tac. Qed. Lemma csum_le2l' a b c : natp a -> cardinalp b -> cardinalp c -> (a +c b) <=c (a +c c) -> b <=c c. Proof. move => aN cb cc abc. by case: (cleT_el cb cc) => // /(csum_Meqlt aN) /(cleNgt abc). Qed. Lemma csum_lt2l' a b c : natp a -> cardinalp b -> cardinalp c -> (a +c b) b aN cb cc [abc nac]. split;[ apply: (csum_le2l' aN cb cc abc) | dneg bc; ue]. Qed. Section Simplification. Variables a b c: Set. Hypothesis (aN: natp a) (bN: natp b) (cN: natp c). Lemma csum_le2l: (a +c b) <=c (a +c c) -> b <=c c. Proof. exact:(csum_le2l' aN (CS_nat bN) (CS_nat cN)). Qed. Lemma csum_le2r: (b +c a) <=c (c +c a) -> b <=c c. Proof. rewrite !(csumC _ a); apply:csum_le2l. Qed. Lemma csum_lt2l: (a +c b) b [abc nac]; split;[ apply: (csum_le2l abc) | dneg bc; ue]. Qed. Lemma csum_lt2r: (b +c a) b \0c -> (a *c b) <=c (a *c c) -> b <=c c. Proof. move=>naz abc; case: (NleT_el bN cN) => // ltcb. case: (cleNgt abc (cprod_Meqlt aN bN ltcb naz)). Qed. Lemma cprod_le2r: a <> \0c -> (b *c a) <=c (c *c a) -> b <=c c. Proof. rewrite !(cprodC _ a); apply:cprod_le2l. Qed. Lemma cprod_lt2l: (a *c b) b [abc nac]; case: (equal_or_not a \0c) => anz. by case: nac; rewrite anz !cprod0l. split; [ by apply: cprod_le2l | move => bc;case: nac; ue]. Qed. Lemma cprod_lt2r: (b *c a) b natp p -> natp q -> q <=c p -> (n <=c p -c q <-> n +c q <=c p). Proof. move => nN pN qN lqp. rewrite - {2} (cdiff_pr lqp) csumC; split => h; first by apply:csum_Meqle. apply:(csum_le2l qN nN (NS_diff _ pN) h). Qed. Lemma cdiff_Mle a b c: natp a -> natp b -> c <=c (a +c b) -> (c -c b) <=c a. Proof. move=> aN bN cab. move: (NS_le_nat cab (NS_sum aN bN)) => cN. case: (NleT_ee cN bN) => cb; first by rewrite cdiff_wrong; fprops. by apply: (csum_le2r bN (NS_diff b cN) aN); rewrite (cdiff_rpr cb). Qed. Lemma cdiff_Mlt a b c: natp a -> natp c -> b <=c c -> c (c -c b) aN cN bc cab. move: (NS_le_nat bc cN) => bN. by apply: (csum_lt2r bN (NS_diff b cN) aN); rewrite (cdiff_rpr bc). Qed. Lemma cdiff_Mlt' a b c: natp a -> natp b -> a <> \0c -> c (c -c b) aN bN anz cab. move: (NS_lt_nat cab (NS_sum aN bN)) => cN. case: (NleT_ee cN bN) => cb. by rewrite (cdiff_wrong cb); apply/(strict_pos_P1 aN). by apply: (csum_lt2r bN (NS_diff b cN) aN); rewrite (cdiff_rpr cb). Qed. (** ** EIII-5-3 Intervals in sets of integers *) Definition Nintcc a b := interval_cc Nat_order a b. Definition Nint a:= interval_co Nat_order \0c a. Definition Nintc a:= Nintcc \0c a. Definition Nint1c a:= Nintcc \1c a. Definition Nint_cco a b := graph_on cardinal_le (Nintcc a b). Lemma Nint_S a b: sub (Nintcc a b) Nat. Proof. by move => t /Zo_S; rewrite (proj2 Nat_order_wor). Qed. Lemma Nint_S1 a: sub (Nint a) Nat. Proof. by move => t /Zo_S; rewrite (proj2 Nat_order_wor). Qed. Lemma Nintc_i b x: inc x (Nintc b) -> x <=c b. Proof. by move /Nint_ccP => [_ [_ _ h]]. Qed. Lemma NintcP b: natp b -> forall x, inc x (Nintc b) <-> x <=c b. Proof. move=> bN x; split; first by apply: Nintc_i. by move => h;apply /(Nint_ccP1 NS0 bN); move: (czero_least (proj31 h)). Qed. Lemma Nint1cP b: natp b -> forall x, inc x (Nint1c b) <-> (x <> \0c /\ x <=c b). Proof. move=> bN x; apply: (iff_trans (Nint_ccP1 NS1 bN x)). split; move => [pa pb]; split => //. exact: (nesym (proj2 (clt_leT clt_01 pa))). exact: (cge1 (proj31 pb) pa). Qed. Lemma Nint1cPb b: natp b -> forall x, (inc x (Nint1c b) <-> (\1c <=c x /\ x <=c b)). Proof. move=> aN x; apply: (Nint_ccP1 NS1 aN). Qed. Lemma NintE n: natp n -> Nint n = n. Proof. move=> nN; have h := (Nint_coP1 NS0 nN). set_extens t; first by move/h => [_ /(NltP nN)]. move/(NltP nN)=> ltn; apply/h; split => //;apply: (czero_least (proj31_1 ltn)). Qed. Lemma Nint_i a x: inc x (Nint a) -> x /Nint_coP [_ [[_ _ ha] hb]]; split. Qed. Lemma NintP a: natp a -> forall x, (inc x (Nint a) <-> x aN x; rewrite (NintE aN); apply: iff_sym;apply: NltP. Qed. Lemma Nint_co_cc p: natp p -> Nintc p = Nint (csucc p). Proof. move => pN;move:(NS_succ pN) => snP; rewrite (NintE snP);set_extens t. - by move => /(NintcP pN) /(NleP pN). - by move => /(NleP pN) /(NintcP pN). Qed. Lemma NintcE n: natp n -> Nintc n = csucc n. Proof. by move=> nN; rewrite (Nint_co_cc nN) (NintE (NS_succ nN)). Qed. Lemma NintsP a: natp a -> forall x, (inc x (Nint (csucc a)) <-> x <=c a). Proof. move=> aN; rewrite - (Nint_co_cc aN); exact (NintcP aN). Qed. Lemma Nint_co00: Nint \0c = emptyset. Proof. by rewrite (NintE NS0). Qed. Lemma Nint_co01: (inc \0c (Nint \1c) /\ Nint \1c = singleton \0c). Proof. rewrite (NintE NS1); split => //; apply: set1_1. Qed. Lemma Nint_cc00: Nintc \0c = singleton \0c. Proof. by rewrite -(proj2 Nint_co01) - succ_zero (Nint_co_cc NS0). Qed. Lemma Nint_si a: natp a -> inc a (Nint (csucc a)). Proof. move=> aN; apply /(NintsP aN); fprops. Qed. Lemma Nint_M a: natp a -> sub (Nint a) (Nint (csucc a)). Proof. move => aN; rewrite (NintE aN) (NintE (NS_succ aN)) (succ_of_Nat aN). apply:subsetU2l. Qed. Lemma Nint_M1 a b: natp b -> a <=c b -> sub (Nint a) (Nint b). Proof. by move=> bN ab; rewrite (NintE bN) (NintE (NS_le_nat ab bN)); case: ab. Qed. Lemma Nint_pr4 n: natp n -> ( ((Nint n) +s1 n = (Nint (csucc n))) /\ ~(inc n (Nint n))). Proof. move=> nN. split; last by move/(NintP nN) => [_]. by rewrite (NintE nN) (NintE (NS_succ nN)) (succ_of_Nat nN). Qed. Lemma Nint_pr5 n (si := Nintcc \1c n): natp n -> ( (si +s1 \0c = Nintc n) /\ ~(inc \0c si)). Proof. move=> nN; split. set_extens x. case /setU1_P; first by move /(Nint_ccP1 NS1 nN) => [_]/(NintcP nN). move => ->; apply /(NintcP nN); fprops. move /(NintcP nN) => h; apply /setU1_P. case: (equal_or_not x \0c) => xz; [ by right | left ]. apply /(Nint_ccP1 NS1 nN);split => //;apply: cge1 => //; exact: (proj31 h). move /(Nint_ccP1 NS1 nN) => [ /cleNgt []]; exact: clt_01. Qed. Lemma incsx_intsn x n: natp n -> inc x (Nint n) -> inc (csucc x) (Nint (csucc n)). Proof. by move => nN; move/(NintP nN) => /cltSS /(NintP (NS_succ nN)). Qed. Lemma inc0_int01: inc \0c (Nint \1c). Proof. by apply /NintP; fprops; apply: clt_01. Qed. Lemma inc0_int02: inc \0c (Nint \2c). Proof. by apply /NintP; fprops; apply: clt_02. Qed. Lemma Nat_induction5 (r:property) a: natp a -> r \0c -> (forall n, n r n -> r (csucc n)) -> (forall n, n <=c a -> r n). Proof. move=> aN r0 rs. move => n na; move: (NS_le_nat na aN) => nn; move: n nn na. apply: Nat_induction => //n nN Hrec. move/(cleSltP nN) => na; apply:(rs _ na (Hrec (proj1 na))). Qed. Section IntervalNatwo. Variables (a b: Set). Hypotheses (aN: natp a)(bN: natp b). Lemma Ninto_wor: worder_on (Nint_cco a b) (Nintcc a b). Proof. move: cle_wor => wo. have r: (forall x, inc x (interval_cc Nat_order a b) -> x <=c x). move=> x xb; exact (cleR (CS_nat (Nint_S xb))). by move: (wordering_pr wo r). Qed. Lemma Ninto_gleP x y: gle (Nint_cco a b) x y <-> [/\ inc x (Nintcc a b), inc y (Nintcc a b) & x <=c y]. Proof. apply: graph_on_P1. Qed. Lemma Ninto_gleP2 x y: gle (Nint_cco a b) x y <-> [/\ a <=c x, y <=c b & x <=c y]. Proof. split. move/Ninto_gleP=> [] /(Nint_ccP1 aN bN) [pa pb] /(Nint_ccP1 aN bN) [pc pd] pe. done. move => [pa pb pc]; move:(cleT pc pb) (cleT pa pc) => pd pe. by apply/Ninto_gleP; split => //; apply /(Nint_ccP1 aN bN). Qed. End IntervalNatwo. Definition Nint_co a := graph_on cardinal_le (Nint a). Section IntervalNatwo1. Variable (a: Set). Hypothesis (aN: natp a). Lemma Nintco_wor: worder_on (Nint_co a) (Nint a). Proof. move: cle_wor => wo. have r: forall x, inc x (Nint a) -> x <=c x. move=> x xi; move: (Nint_S1 xi) => xN; fprops. by move: (wordering_pr wo r). Qed. Lemma Nintco_gleP x y: gle (Nint_co a) x y <-> (x <=c y /\ y [] /(NintP aN) xa /(NintP aN) ya xy. move=> [xy ya]; move:(cle_ltT xy ya)=> h. by apply/graph_on_P1; split => //;apply /(NintP aN). Qed. End IntervalNatwo1. Lemma segment_Nat_order n: natp n -> segment Nat_order n = Nint n. Proof. move=> xN; set_extens t;move /Zo_P => [pa pb];apply:Zo_i => //;last by case: pb. move: pb => [] /Nat_order_leP [tn aa bb] cc. split; first by apply/Nat_order_leP; split; fprops. split; [ by apply/Nat_order_leP; split; fprops | exact ]. Qed. Lemma segment_Nat_order1 n: natp n -> segment Nat_order n = n. Proof. by move=> nN; rewrite (segment_Nat_order nN) (NintE nN). Qed. Definition rest_plus_interval a b := Lf(fun z => z +c b)(Nintcc \0c a) (Nintcc b (a +c b)). Definition rest_minus_interval a b := Lf(fun z => z -c b) (Nintcc b (a +c b)) (Nintcc \0c a). Theorem restr_plus_interval_is a b (f := (rest_plus_interval a b)) (g := (rest_minus_interval a b)): natp a -> natp b -> [/\ bijection f, bijection g, g = inverse_fun f & order_isomorphism f (Nint_cco \0c a) (Nint_cco b (a +c b))]. Proof. move=> aN bN. have zN:= NS0. have abN:= (NS_sum aN bN). set E1:= Nintc a. set E2:= Nintcc b (a +c b). have tap: lf_axiom (fun z => z +c b) E1 E2. move => z /(NintcP aN) za; apply/(Nint_ccP1 bN abN); split. rewrite csumC; apply: csum_M0le; fprops. by apply: csum_Mleeq. have tam: lf_axiom (fun z => z -c b) E2 E1. move => z /(Nint_ccP1 bN abN) [bt tab]; apply /(NintcP aN). move: (NS_diff b (NS_le_nat tab abN)) => sN; apply: cdiff_Mle =>//. 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: (Nint_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 xN:=(Nint_S xs). move: xs => /(Nint_ccP1 bN abN) [bx xaN]. have aux: inc (x -c b) (Nintcc \0c a). apply/(NintcP aN); apply: cdiff_Mle =>//. 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: (Ninto_wor \0c a) => [[o1 _ ] sr1]. move: (Ninto_wor b (a +c b))=> [[o2 _ ] sr2]. hnf;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). split; move /Ninto_gleP => [pa pb pc]; apply/Ninto_gleP. by split; try (apply: tap => //); apply: csum_Mleeq. split=> //; apply:(csum_le2l bN (Nint_S xsf) (Nint_S ysf)). by rewrite csumC (csumC b y). Qed. Lemma card_Nintc a: natp a -> cardinal (Nintc a) = csucc a. Proof. by move => aN; rewrite (NintcE aN) (card_card (CS_succ _)). Qed. Lemma finite_set_nat n: natp n -> finite_set n. Proof. by move => nN; apply/card_finite_setP; rewrite (card_nat nN). Qed. Lemma card_Nint a: natp a -> cardinal (Nint a) = a. Proof. by move => aN; rewrite (NintE aN)(card_nat aN). Qed. Lemma card_Nintcp a: natp a -> a <> \0c -> cardinal (Nintc (cpred a)) = a. Proof. move=> aN naz. by move: (cpred_pr aN naz) => [fp ass]; rewrite card_Nintc. Qed. Theorem card_Nintcc a b: a <=N b -> cardinal (Nintcc a b) = csucc (b -c a). Proof. move=> [aN bN ab]. move: (cdiff_pr ab) (NS_diff a bN) => aux cN. rewrite csumC in aux. set (c:= b -c a) in *. have fb:= (proj41 (restr_plus_interval_is cN aN)). have eq: (Nintcc \0c c) \Eq (Nintcc a b). exists (rest_plus_interval c a); rewrite /rest_plus_interval. hnf;rewrite lf_source lf_target; split => //; ue. by rewrite -(card_Nintc cN); symmetry;apply /card_eqP. Qed. Lemma card_Nint1c a: natp a -> cardinal (Nint1c a) = a. Proof. move => aN. case: (equal_or_not a \0c) => anz. have aux: (Nint1c \0c = emptyset). apply /set0_P => y; move /(Nint1cPb NS0)=> [c1y cy0]. exact: (cleNgt (cleT c1y cy0) clt_01). rewrite anz aux; apply: cardinal_set0. have aux1: \1c <=c a by apply: cge1; fprops. have aux: \1c <=N a by split;fprops. have so:= (NS_diff \1c aN). by rewrite card_Nintcc // Nsucc_rw // csumC; apply: cdiff_pr. Qed. Lemma finite_Nintcc a b: finite_set (Nintcc a b). Proof. apply/card_finite_setP. case: (p_or_not_p (a <=N b)) => h. rewrite card_Nintcc //; move: h => [aN bN _]; fprops. have ->: (Nintcc a b) = emptyset. apply/set0_P => t /Zo_hi [/Nat_order_leP [pa _ pc] /Nat_order_leP [_ pe pf]]. case: h; split => //; exact:cleT pc pf. rewrite cardinal_set0;fprops. Qed. Lemma finite_Nint a: finite_set (Nint a). Proof. have aux:sub (Nint a) (Nintcc \0c a). by move => t /Zo_P [pa [pb [pc _]]]; apply /Zo_P. apply: (sub_finite_set aux (finite_Nintcc \0c a)). Qed. Lemma infinite_Nat_alt: ~(finite_set Nat). Proof. move /NatP =>h. move: (sub_smaller (Nint_S (a:=\0c) (b:=cardinal Nat))). by rewrite (card_Nintc h); case /(cleSltP 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 hnf; 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 => // 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 (Nint_cco \1c (cardinal (substrate r))). Proof. move=> tot fs. move/NatP: (fs) => fs'. have [pa pb] := (Ninto_wor \1c (cardinal (substrate r))). move /card_eqP:(card_Nint1c fs') ;rewrite /Nint1c - pb => /EqS h. by apply: (isomorphism_worder_finite tot (worder_total pa) fs). Qed. Theorem finite_ordered_interval1 r: total_order r -> finite_set (substrate r) -> exists !f, order_isomorphism f r (Nint_co (cardinal (substrate r))). Proof. move=> tor fs. move/NatP: (fs) => fs'. have wor := (finite_set_torder_wor tor fs). move /card_eqP:(card_Nint fs'); rewrite - (proj2 (Nintco_wor _)) => /EqS e. have tor' := (worder_total (proj1(Nintco_wor (cardinal (substrate r))))). by apply: (isomorphism_worder_finite tor tor' fs). Qed. Lemma worder_decreasing_finite r r' (f:fterm): worder r -> worder r' -> (forall i, inc i (substrate r) -> inc (f i) (substrate r')) -> (forall i j, glt r i j -> glt r' (f j) (f i)) -> finite_set (substrate r). Proof. move=> wor wor' ta finc; move: (proj1 wor') => or'. move: Nat_order_wor=> [wob bsr]. case: (isomorphism_worder3 wob wor); last first. move => [x]; rewrite bsr; move => xn [g [pa pb]]. have ss:=(@sub_segment Nat_order x). rewrite (iorder_sr (proj1 wob) ss) (segment_Nat_order xn) => fp _. have cc:cardinal (Nint x)= cardinal (substrate r) by apply/card_eqP; exists g. by rewrite /finite_set - cc; apply: finite_Nint. move =>[g [sr isg]]. have gsi:=(order_morphism_sincr isg). move: isg => [or _ [fg sg tg] incfg]. have sg1: source g = Nat by rewrite sg bsr. move: sr => [sr1 sr2]. set Y := fun_image (range (graph g)) f. have Ysr: sub Y (substrate r'). move => t /funI_P [z /(range_fP fg) [x1 x1g x1p] ->]; apply: ta. rewrite x1p; apply: sr1; Wtac. have yi n: natp n -> inc (f (Vf g n)) Y. by move => nN;apply/funI_P;exists (Vf g n)=> //;Wtac; rewrite sg1. have neY: nonempty Y by exists (f (Vf g \0c)); apply (yi _ NS0). move:(worder_prop wor' Ysr neY) => [y /funI_P [z za zb] yb]. move/(range_fP fg): za => [n nN np]; rewrite sg1 in nN. have lt1: glt Nat_order n (csucc n). move:(cltS nN) => [qa qb]. split => //; apply /Nat_order_leP; split => //; apply: (NS_succ nN). move:(finc _ _ (gsi _ _ lt1)); rewrite - np - zb => lt2. have /yb lt3: inc (f (Vf g (csucc n))) Y by apply:yi; apply:NS_succ. order_tac. Qed. (** A finite sum or product can be defined by induction *) Lemma induction_on_sum n f (sum := fun n => csumb n f): natp n -> sum (csucc n) = (sum n) +c (f n). Proof. move=> nN; rewrite /sum (succ_of_Nat nN); apply csumA_setU1. apply:(nat_irreflexive nN). Qed. Lemma induction_on_prod n f (prod := fun n=> cprodb n f): natp n -> prod (csucc n) = (prod n) *c (f n). Proof. move=> nN; rewrite /prod (succ_of_Nat nN); apply cprodA_setU1. apply:(nat_irreflexive nN). Qed. Lemma fct_sum_rec0 f n: natp n -> csumb (Nintc n) f = (csumb (Nint1c n) f) +c (f \0c). Proof. move=> nN; move: (Nint_pr5 nN) => [<- aux]. by apply csumA_setU1. Qed. Lemma fct_sum_rec1 f n: natp n -> csumb (csucc n) f = (csumb n (fun i=> f (csucc i))) +c (f \0c). Proof. move=> nN. rewrite - (NintE (NS_succ nN)) -(Nint_co_cc nN). rewrite (fct_sum_rec0 _ nN); congr (_ +c (f \0c)). have aux u: inc u n -> cardinalp u. move =>h; exact:(CS_nat (NS_inc_nat nN h)). apply: csum_Cn2; split. + move => t /(NltP nN) => tn; apply /(Nint1cP nN). by split; [ apply: succ_nz | apply/(cleSltP (NS_lt_nat tn nN))]. + by move=> u v un vn;apply: succ_injective1; apply: aux. + move=> y; bw; move/(Nint1cP nN) => [nyz le_s]. have [pN ns] := (cpred_pr (NS_le_nat le_s nN) nyz). exists (cpred y) => //; apply/(NltP nN); apply/(cleSltP pN); ue. Qed. Lemma fct_sum_rev f n (I := (csucc n)): natp n -> csumb I f = csumb I (fun i=> f (n -c i)). Proof. move=> nN. have snN:= NS_succ nN. apply: csum_Cn2; split. + by move=> x /(NleP nN) [_ cn _];apply /(NleP nN); apply: cdiff_ab_le_a. + move=> x y /(NleP nN) xn /(NleP nN) yn => h. by rewrite - (double_diff nN xn) -(double_diff nN yn) h. + bw => y /(NleP nN) yn; rewrite -(double_diff nN yn). exists (n -c y) => //; apply /(NleP nN). exact: (cdiff_ab_le_a _ (proj32 yn)). 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 = \1c. 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 = \0c. Proof. move => xa; rewrite char_fun_V_b ? setC_0;fprops. 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;case: card1_nz. move: (p u t (AB _ uA) tB). rewrite (char_fun_V_a AB uA) (char_fun_V_b AB) //. by apply /setC_P. Qed. Lemma char_fun_setC A B x: sub A B -> inc x B -> Vf (char_fun (B -s A) B) x = \1c -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) => xA. rewrite char_fun_V_b //. rewrite char_fun_V_a //; symmetry; apply: cdiff_nn; fprops. by rewrite setC_K. have xc: inc x (B -s A) by apply/setC_P. by rewrite char_fun_V_a // char_fun_V_b // (cdiff_n0 NS1). 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 =>[_]. by rewrite char_fun_V_b // char_fun_V_b //; 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 // cprod0l. 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'. by rewrite (char_fun_V_a A'B xA') char_fun_V_a //; 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 *) Definition cdivision_prop a b q r := a = (b *c q) +c r /\ r natp b -> natp q -> natp r -> b <> \0c -> (cdivision_prop a b q r <-> [/\ (b *c q) <=c a, a aN bN qN rN nzb; rewrite /cdivision_prop. set (w:= b *c q). rewrite Nsucc_rw // cprodC cprodDr cprodC cprod1l; fprops. have wN: natp w 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: natp (b *c q +c b) by fprops. split; first by symmetry; apply: cdiff_pr =>//. move: ltas => /(card_ltP aN aux) [c [cN nzc s]] {aux}. move: (cdiff_pr lwa); rewrite -rv=> aux. apply /(card_ltP rN bN); exists c => //; split => //. by apply: (csum_eq2l wN (NS_sum rN cN) bN);rewrite csumA aux. Qed. Lemma cdivision_unique a b q r q' r': natp a -> natp b -> natp q -> natp r -> natp q' -> natp r' -> b <> \0c -> cdivision_prop a b q r -> cdivision_prop a b q' r' -> (q = q' /\ r =r'). Proof. move=> aN bN qN rN q'N r'N nbz. move /(cdivision_prop_alt aN bN qN rN nbz)=> [le1 lt1 e1]. move /(cdivision_prop_alt aN bN q'N r'N nbz)=> [le2 lt2 e2]. suff : q = q' by move=> h; split => //; rewrite e1 e2 h. move: (cprod_lt2l bN q'N (NS_succ qN) (cle_ltT le2 lt1)). move: (cprod_lt2l bN qN (NS_succ q'N) (cle_ltT le1 lt2)). by move /(cltSleP q'N) => pa /(cltSleP qN) => /(cleA pa). Qed. Lemma cdivision_exists a b: natp a -> natp b -> b <> \0c -> exists q r, [/\ inc q Nat, inc r Nat & cdivision_prop a b q r]. Proof. move=> aN bN nzb. move: (NS_succ aN) => saN. have ep: (exists2 x, natp x & a //; apply /cleSltP => //. by rewrite cprodC; apply: Nprod_M1le; fprops. case: (wleast_int_prop ep); first by rewrite cprod0r => /clt0. move => [q [qN psq npq]]. have p1: ((b *c q) <=c a) by move: (NleT_el (NS_prod bN qN) aN); case. move: (cdiff_pr p1); set (r:= a -c (b *c q)) => rp. have rN: natp r by apply: (NS_diff _ aN). by exists q, r; split => //; apply /cdivision_prop_alt. Qed. (* old definition Definition cquo a b := least_ordinal (fun q => a a : E = emptyset. apply /set0_P => y /Zo_hi; rewrite cprod0l; apply: clt0. by rewrite setI_0. Qed. Lemma crem_zero a: natp a -> a %%c \0c = a. Proof. move => h; rewrite /crem cprod0l cdiff_n0 //. Qed. Lemma cdivision a b (q := a %/c b) (r := (a %%c b)): natp a -> natp b -> b <> \0c -> [/\ natp q, natp r & cdivision_prop a b q r]. Proof. move=> aN bN bnz. set E:= Zo Nat (fun z=> (a //. by apply /(cleSltP aN);rewrite cprodC; apply: Nprod_M1le; fprops. move:(inf_Nat EN ne); rewrite /E -/(cquo a b) -/q. move => [/Zo_P [qN qp] qpp]. have rN: natp r by apply: NS_diff => //; apply: NS_prod. split => //. apply /cdivision_prop_alt => //; split => //. case: (equal_or_not q \0c). move=> ->; rewrite cprod0r; apply: czero_least; fprops. move=> qnz; move: (cpred_pr qN qnz); set (z := (cpred q)). move => [zN qs]. case: (cleT_el (CS_prod2 b q) (CS_nat aN)) => //; rewrite qs => h. have /qpp: inc z E by apply/Zo_P. move/ (cleNgt); case; rewrite qs; apply: (cltS zN). Qed. Lemma NS_quo a b: natp (a %/c b). Proof. by apply: NS_inf_Nat; apply: Zo_S. Qed. Lemma NS_rem a b: natp a -> natp b -> natp (a %%c b). Proof. move => aN bN. case: (equal_or_not b \0c) => bnz. rewrite bnz crem_zero //. exact: (proj32 (cdivision aN bN bnz)). Qed. Hint Resolve NS_rem NS_quo: fprops. Lemma cdiv_pr a b: natp a -> natp b -> a = (b *c (a %/c b)) +c (a %%c b). Proof. move => aN bN. case: (equal_or_not b \0c) => bnz. rewrite bnz (crem_zero aN) cquo_zero cprod0r; aw; fprops. by move: (cdivision aN bN bnz) =>[_ _ [h _]]. Qed. Lemma crem_pr a b: natp a -> natp b -> b <> \0c -> (a %%c b) aN bN bnz; move: (cdivision aN bN bnz) =>[_ _ [_]]. Qed. Lemma cquorem_pr a b q r: natp a -> natp b -> natp q -> natp r -> cdivision_prop a b q r -> (q = a %/c b /\ r = a %%c b). Proof. move => aN bN qN rN p'. case: (equal_or_not b \0c) => bnz. move: p' => [_ ]; rewrite bnz =>h; case: (clt0 h). move: (cdivision aN bN bnz)=> [qqN rrN p]. apply: (cdivision_unique aN bN qN rN qqN rrN bnz p' p). Qed. Lemma cquorem_pr0 a b q: natp a -> natp b -> natp q -> b <> \0c -> a = (b *c q) -> (q = a %/c b /\ \0c = a %%c b). Proof. move => aN bN qN bnz p'. apply: cquorem_pr; fprops. hnf; rewrite -p' (Nsum0r aN). split; [ trivial | split; [ apply: czero_least | ]]; fprops. Qed. Lemma crem_small a b: natp b -> a a = a %%c b. Proof. move => bN lab. have aN:= (NS_lt_nat lab bN). have h:cdivision_prop a b \0c a by split => //; rewrite cprod0r; aw; fprops. exact: (proj2 (cquorem_pr aN bN NS0 aN h)). Qed. Lemma cquo_small a b: natp b -> a a %/c b = \0c. Proof. move => bN lab. have aN:=(NS_lt_nat lab bN). have h: cdivision_prop a b \0c a. by split => //; rewrite cprod0r (csum0l (CS_nat aN)). symmetry; exact:(proj1 (cquorem_pr aN bN NS0 aN h)). Qed. Lemma cdivides_pr a b: b %|c a -> a = b *c (a %/c b). Proof. move => [aN bN dv]. move: (cdiv_pr aN bN); rewrite dv. by rewrite (Nsum0r (NS_prod bN (NS_quo a b))). Qed. Lemma cdivides_pr1 a b: natp a -> natp b -> b %|c (b *c a). Proof. move=> aN bN. move: (NS_prod bN aN) => pN. split => //. case: (equal_or_not b card_zero) => bnz. rewrite bnz cprod0l crem_zero //; fprops. by case: (cquorem_pr0 pN bN aN bnz (refl_equal (b *c a))). Qed. Lemma cdivides_pr2 a b q: natp a -> natp b -> natp q -> b <> \0c -> a = b *c q -> q = a %/c b. Proof. move => aN bN qN nzb abq. by case: (cquorem_pr0 aN bN qN nzb abq). Qed. Lemma cdivides_one a: natp a -> \1c %|c a. Proof. move=> aN; rewrite - (cprod1l (CS_nat aN)). apply: (cdivides_pr1 aN NS1). Qed. Lemma cquo_one a: natp a -> a %/c \1c = a. Proof. move=> aN; symmetry; apply: cdivides_pr2; 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: natp b -> natp q -> b <> \0c -> (b *c q) %/c b = q. Proof. move=> *; symmetry; apply: cdivides_pr2 =>//; fprops. Qed. Lemma cdivision_of_zero n: natp n -> (n %|c \0c /\ \0c %/c n = \0c). Proof. move: NS0 => n0 aN; rewrite /cdivides. have aux: \0c = n *c \0c by rewrite cprod0r. case: (equal_or_not n \0c) => anz. by rewrite anz cquo_zero crem_zero. by move: (cquorem_pr0 n0 aN n0 anz aux) => [p1 p2]. Qed. Lemma cdivides_zero n: natp n -> n %|c \0c. Proof. by move/cdivision_of_zero => []. Qed. Lemma crem_of_zero n: natp n -> \0c %%c n = \0c. Proof. by move /cdivides_zero => []. Qed. Lemma cdivision_itself a: natp a -> a <> \0c -> (a %|c a /\ a %/c a = \1c). Proof. move=> aN anz; rewrite /cdivides. have aux:a = a *c \1c by rewrite (cprod1r (CS_nat aN)). by move: (cquorem_pr0 aN aN NS1 anz aux) => [p1 p2]. Qed. Lemma cdivides_itself n: natp n -> n %|c n. Proof. move=> aN; case: (equal_or_not n \0c) => nz. by rewrite {2} nz; apply:cdivides_zero. exact:(proj1 (cdivision_itself aN nz)). Qed. Lemma cquo_itself a: natp a -> a <> \0c -> a %/c a = \1c. Proof. by move=> aN anz; move: (cdivision_itself aN anz) => [ _ h]. 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 \0c) => bnz. by rewrite bnz cquo_zero cquo_zero cprod0r. move: d1 d2 => [a'N aN _][_ bN _]. have pN: natp ((a %/c b) *c (a' %/c a)) by fprops. rewrite - (cdivides_pr2 a'N bN pN bnz h). by rewrite cprodC. Qed. Lemma cdivides_trans2 a b c: natp c -> b %|c a -> b %|c (a *c c). Proof. move=> cN ba. have aN: (inc a Nat) by move: ba => [h _]. have aux:= (cdivides_pr1 cN aN). apply: (cdivides_trans aux ba). Qed. Lemma cquo_simplify a b c: natp a -> natp b -> natp c -> b <> \0c -> c <> \0c -> (a *c c) %/c (b *c c) = a %/c b. Proof. move=> aN bN cN bnz cnz. have [qN rN []] := (cdivision aN bN bnz). set q:= (a %/c b); set r := a %%c b. move=> e1 lrb; symmetry. move: (NS_prod aN cN)(NS_prod bN cN)(NS_prod (NS_rem aN bN) cN) => p1 p2 p3. have dv: (cdivision_prop (a *c c) (b *c c) q (r *c c)). split. rewrite (cprodC b c) - cprodA (cprodC c _). by rewrite - cprodDr e1. by rewrite (cprodC b c) cprodC; apply: cprod_Meqlt. exact (proj1 (cquorem_pr p1 p2 qN p3 dv)). 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 cprodDl -am -bm. move: d1 d2 => [aN bN _][a'N _ _]. have sN:natp s by rewrite /s; fprops. split; first by apply: cdivides_pr1 =>//. case: (equal_or_not b \0c) => bs. rewrite {2} /s bs ! cquo_zero; aw; fprops. by symmetry; apply: (cdivides_pr2 (NS_prod bN sN) bN sN bs). 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 => [aN bN _][a'N _ _]. move: (NS_quo a b)(NS_quo a' b) => q1 q2. have q3: (a' %/c b) <=c (a %/c b). case: (equal_or_not b \0c) => bnz. rewrite bnz ! cquo_zero; fprops. rewrite am bm in le; apply: (cprod_le2l bN q2 q1 bnz le). have ->: (a -c a' = b *c s). by rewrite /s cprodBl // -am -bm. have sN: natp s 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_nn; fprops. by symmetry; apply: (cdivides_pr2 (NS_prod bN sN) bN sN bs). Qed. (** ** EIII-5-7 Expansion to base b *) (** Definition by induction on N *) Definition induction_defined0 (h: fterm2) (a: Set) := transfinite_defined Nat_order (fun u => Yo(source u = \0c) a (h (cpred (source u))(Vf u (cpred (source u))))). Definition induction_defined (s: fterm) (a: Set) := transfinite_defined Nat_order (fun u => Yo(source u = \0c) a (s (Vf u (cpred (source u))))). Lemma induction_defined_pr0 (h:fterm2) a (f := induction_defined0 h a): [/\ source f = Nat, surjection f, Vf f \0c = a & forall n, natp n -> Vf f (csucc n) = h n (Vf f n)]. Proof. rewrite /f /induction_defined0. set p := (fun u : Set => _). have [wo sr] := Nat_order_wor. move: (transfinite_defined_pr p wo) => []. set g := (transfinite_defined Nat_order p) => pa pb pc. have p1: forall a, natp a -> source (restriction1 f (segment Nat_order a))= a. by move=> b bN; rewrite /restriction1 corresp_s segment_Nat_order1. rewrite sr in pb pc; split => //. by rewrite (pc _ NS0) /restriction_to_segment /p (p1 _ NS0); Ytac0. move=> n nN; move:(NS_succ nN) => snN;rewrite (pc _ snN) /p (p1 _ snN). rewrite (Y_false (@succ_nz n)) (cpred_pr2 nN). congr (h n _); rewrite restriction1_V //; first by fct_tac. rewrite segment_Nat_order // ? pb;apply: Nint_S1. by rewrite (segment_Nat_order snN); apply: Nint_si. Qed. Lemma induction_defined_pr s a (f := induction_defined s a): [/\ source f = Nat, surjection f, Vf f \0c = a & forall n, natp n -> Vf f (csucc n) = s (Vf f n)]. Proof. rewrite /f /induction_defined. set p := (fun u : Set => _). have [wo sr] := Nat_order_wor. move: (transfinite_defined_pr p wo). set g := (transfinite_defined Nat_order p). move=> [pa pb pc]. have p1: forall a, natp a -> source (restriction1 f (segment Nat_order a))= a. by move=> b bN; rewrite /restriction1 corresp_s segment_Nat_order1. rewrite sr in pb pc; split => //. by rewrite (pc _ NS0) /restriction_to_segment /p (p1 _ NS0); Ytac0. move=> n nN; move:(NS_succ nN) => snN;rewrite (pc _ snN) /p (p1 _ snN). rewrite (Y_false (@succ_nz n)) (cpred_pr2 nN). congr (s _); rewrite restriction1_V //; first by fct_tac. rewrite segment_Nat_order // ? pb; apply: Nint_S1. by rewrite (segment_Nat_order snN); apply: Nint_si. Qed. Lemma integer_induction0 h a: exists! f, [/\ source f = Nat, surjection f, Vf f \0c = a & forall n, natp n -> Vf f (csucc 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: Nat_induction; first by ue. by move=> n nN eq; rewrite (xs _ nN) (ys _ nN) eq. Qed. Lemma integer_induction (s:fterm) a: exists! f, [/\ source f = Nat, surjection f, Vf f \0c = a & forall n, natp n -> Vf f (csucc n) = s (Vf f n)]. Proof. move: (integer_induction0 (fun _ x:Set => s x) a) => //. Qed. Definition induction_term s a := Vf (induction_defined0 s a). Lemma induction_term0 s a: induction_term s a \0c = a. Proof. by move: (induction_defined_pr0 s a)=> [sf sjf w0 ws]. Qed. Lemma induction_terms s a n: natp n -> induction_term s a (csucc n) = s n (induction_term s a n). Proof. move: (induction_defined_pr0 s a)=> [sf sjf w0 ws] nN. by rewrite /induction_term ws. Qed. (** Expansion to base b *) Lemma b_power_k_large a b: natp a -> natp b -> \1c a <> \0c -> exists k, [/\ natp k, (b ^c k) <=c a & a aN bN l1b naz. have exp:(exists2 x, natp x & a //; apply: cpow_M1lt;fprops. case: (wleast_int_prop exp). rewrite cpowx0 => a1; case(cltNge a1 (cge1 (CS_nat aN) naz)). move => [k [kN pks npk]]. exists k; split => //. by case: (NleT_el (NS_pow bN kN) aN) => // h; case: npk. Qed. Definition expansion f b k := [/\ natp b, natp k, \1c (Vg f i) (Vg f i) *c (b ^c i)). Section Base_b_expansion. Variables f g b k k': Set. Hypothesis Exp: expansion f b k. Hypothesis Expg: expansion g b (csucc k'). Hypothesis ck' : cardinalp k'. Lemma expansion_prop0P i: (inc i (domain f)) <-> i _]] := Exp; apply: iff_sym ;exact: (NltP kn). Qed. Lemma expansion_prop1 i: i natp (Vg f i). Proof. move: Exp => [bN kn _ [_ d v]] /expansion_prop0P /v lt1. exact:(NS_lt_nat lt1 bN). Qed. Lemma expansion_prop2: finite_int_fam (Lg (domain f) (fun i=> (Vg f i) *c (b ^c i))). Proof. have [bN kN b2 [fgf df vf]] := Exp. hnf; rewrite /allf; bw; split. move=> i idf; bw; move /expansion_prop0P: idf => idf. apply: (NS_prod (expansion_prop1 idf) (NS_pow bN (NS_lt_nat idf kN))). by rewrite df; apply: finite_set_nat. Qed. Lemma expansion_prop3: natp (expansion_value f b). Proof. rewrite /expansion_value; apply: finite_sum_finite. apply: expansion_prop2. Qed. Lemma expansion_prop4: natp k'. Proof. by move: Expg => [_ kN' _ _]; apply: NS_nsucc. Qed. Lemma expansion_prop5: expansion (restr g k') b k'. Proof. have k'n :=expansion_prop4. have [bN kN b2 [fgf df vf]] := Expg. have dr: domain (restr g k') = k' by bw; ue. split;fprops; split; fprops. by rewrite dr=> i ic; bw; apply: vf; rewrite df; apply: (proj33(cleS k'n)). Qed. Lemma expansion_prop6: natp (Vg g k'). Proof. have k'n := expansion_prop4. have [bN kn _ [_ d v]] := Expg. have kd: (inc k' (domain g)) by rewrite d; apply/(NleP k'n); fprops. exact:(NS_lt_nat (v _ kd) bN). Qed. Lemma expansion_prop7: (expansion_value g b) = (expansion_value (restr g k') b) +c (Vg g k' *c (b ^c k')). Proof. have k'n:= (expansion_prop4). pose h i := (Vg g i) *c (b ^c i). have ->: (Vg g k') *c (b ^c k') = h k' by []. move: (induction_on_sum h k'n). have <- : domain g = (csucc k') by move: Expg=> [_ _ _ [_ dg _]]. rewrite /expansion_value /restr Lg_domain => ->. congr ( _ +c (h k')); apply:csumb_exten => x xi /=; bw. Qed. End Base_b_expansion. Lemma expansion_prop8 f b k x (h:= Lg (csucc k) (fun i=> Yo (i=k) x (Vg f i))) : expansion f b k -> natp x -> x (expansion h b (csucc k) /\ expansion_value h b = (expansion_value f b) +c ((b ^c k) *c x)). Proof. move=> [bN kN b2 [fgf df vf]] xN xb. have eg: (expansion h b (csucc k)). hnf; rewrite /h; bw;split;fprops; split; fprops. move=> i idh; bw; Ytac ik => //; apply: vf. by rewrite df; move: idh; rewrite (succ_of_Nat kN);case/setU1_P. have ck: cardinalp k by fprops. have ksk := (proj33 (cleS kN)). rewrite (expansion_prop7 eg ck); split; first by exact. have ->:(restr h k = f). rewrite /h; symmetry;apply: fgraph_exten; [ exact | fprops | bw; fprops | ]. rewrite df; move=> y ydf /=; bw; fprops. by Ytac w => //; case (nat_irreflexive kN); rewrite -{1} w. have -> //: (Vg h k *c (b ^c k) = (b ^c k) *c x). by rewrite cprodC /h; bw;[ Ytac0 | apply: (Nsucc_i kN)]. Qed. Lemma expansion_prop8_rev f b k x (h := Lg (csucc k) (fun i => Yo (i = \0c) x (Vg f (cpred i)))): expansion f b k -> natp x -> x (expansion h b (csucc k) /\ expansion_value h b = (expansion_value f b) *c b +c x). Proof. move => [bN kN b2 [fgf df vf]] xN xs. have skN:= (NS_succ kN). split. hnf;rewrite /h;split => //; bw; split; fprops => i ii; bw; Ytac iz => //. move/(NleP kN):ii => lij; move:(cpred_pr (NS_le_nat lij kN) iz) => [sa sb]. apply: vf; rewrite df; apply/(NltP kN);apply /(cleSltP sa); ue. have zi: inc \0c (csucc k) by apply /(NleP kN); fprops. have ha:= (CS_nat xN). have hb: (Vg h \0c *c b ^c \0c) = x. by rewrite /h; bw; Ytac0;rewrite cpowx0 (cprod1r ha). rewrite /expansion_value df {1} /h Lg_domain (fct_sum_rec1 _ kN) hb //. congr (_ +c x). move: (kN) (cleR (CS_nat kN)); move: {- 3} k; apply: Nat_induction. move => _. rewrite /csumb !csum_trivial; bw. by rewrite cprod0l. move => n nN Hrec sa. have hc: inc (csucc n) (csucc k) by apply /(NleP kN). have hd:= (@succ_nz n). rewrite (induction_on_sum _ nN) (induction_on_sum _ nN). rewrite (Hrec (cleT (cleS nN) sa)) cprodDr /h; bw; Ytac0. by rewrite (cpred_pr2 nN) (cpow_succ _ nN) cprodA. Qed. Lemma expansion_prop9 f b k: expansion f b k -> (expansion_value f b) Exp. have kN: natp k by move: Exp => [bN kN _ _]. move: k kN f Exp. apply: Nat_induction. move: clt_01 => H g [bN _ b2 [fgf df _]]. rewrite cpowx0 /expansion_value df/csumb csum_trivial; bw. move=> n nN pn g eg. have cn: (cardinalp n) by fprops. rewrite (expansion_prop7 eg cn). have er:= (expansion_prop5 eg cn). have [bN _ b2 [fgf df vg]] := eg. move: (pn _ er). rewrite cpow_succ //. move: (expansion_prop3 er). set (a0:= expansion_value (restr g n) b). set (b0:= b ^c n); set c0:= (Vg g n) *c b0. move => a0N h. have p1: (Vg g n) //;rewrite /c0; fprops. suff le2: (b0 +c c0) <=c (b0 *c b) by apply: clt_leT le1 le2. have cb: cardinalp b0 by fprops. have ->: b0 +c c0 = b0 *c (csucc (Vg g n)). rewrite (Nsucc_rw cN) cprodDl (cprod1r cb) cprodC csumC //. by apply: cprod_Meqle;apply /(cleSltP cN). Qed. Lemma expansion_prop10 f b k: cardinalp k -> expansion f b (csucc k) -> cdivision_prop (expansion_value f b) (b ^c k) (Vg f k) (expansion_value (restr f k) b). Proof. move=> ck ie;split. by rewrite csumC cprodC; apply: expansion_prop7. by 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 kN: natp k by move: eg => [_ kN _ _ ]. move: k kN f g sm ef eg. apply: Nat_induction. rewrite /expansion. move=> f1 g1 sv [bN _ _ [fgf df _]] [_ _ _ [fgg dg _]]. by apply: fgraph_exten; [exact | exact | ue | rewrite df;move=> x /in_set0 ]. move=> n nN pn f g sv ef eg. have cn: cardinalp n by fprops. have p1:= (expansion_prop10 cn ef). have p2:= (expansion_prop10 cn eg). have er1:=(expansion_prop5 ef cn). have er2:= (expansion_prop5 eg cn). have egN :=(expansion_prop3 eg). have q1N:= (expansion_prop6 ef cn). have q2N:= (expansion_prop6 eg cn). have r1N:= (expansion_prop3 er1). have r2N:= (expansion_prop3 er2). rewrite sv in p1. have bN: natp b by move: ef => [bN _]. have cpN: natp (b ^c n) by fprops. have bnz: (b ^c n <> card_zero). have aux: \0c <=c \1c by fprops. have [_ b0]: (\0c [_ _ /(cle_ltT aux) ]. by apply: cpow_nz => bz; case: b0. move: (cdivision_unique egN cpN q1N r1N q2N r2N bnz p1 p2)=> [pt r]. have aux: (restr f n = restr g n) by 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 n). by move:xdf; rewrite df (succ_of_Nat nN); case/setU1_P. have <-: (Vg (restr f n) x = Vg f x) by bw. have <-: (Vg (restr g n) x = Vg g x) by bw. ue. Qed. Lemma expansion_prop11 f g b k: cardinalp k -> expansion f b (csucc k) -> expansion g b (csucc k) -> (Vg f k) (expansion_value f b) ck ef eg ltk. rewrite (expansion_prop7 ef ck) (expansion_prop7 eg ck). have ef1:= (expansion_prop5 ef ck). have eg1:=(expansion_prop5 eg ck). move: (expansion_prop9 ef1). move: (expansion_prop3 ef1). move: (expansion_prop3 eg1). set u:= expansion_value _ _; set v:= expansion_value _ _. move=> uN vN vp. have kn:= (expansion_prop4 ef ck). have fN:=(expansion_prop6 ef ck). have gN:=(expansion_prop6 eg ck). set (B:= b ^c k). have bN: natp b by move: ef => [h _]. have BN: natp B by rewrite /B; fprops. apply: (@clt_leT (B +c ((Vg f k) *c B))). apply: csum_Mlteq; fprops. apply: (@cleT ((Vg g k) *c B)); last first. rewrite csumC; apply: csum_M0le; fprops. move /(cleSltP fN): ltk => ltk. move: (cprod_Mleeq B ltk). by rewrite (Nsucc_rw fN) cprodDr (cprod1l (CS_nat BN)) csumC. Qed. Lemma expansion_restr1 f b k l: expansion f b k -> l <=c k -> expansion (restr f l) b l. Proof. move=> [bN kN b2 [fgf df vg]] lk. have lN:= NS_le_nat lk kN. split; fprops; split; fprops; bw => i idx; bw; apply: vg; rewrite df. by apply: (proj33 lk). Qed. Lemma expansion_restr2 f b k l: expansion f b k -> l <=c k -> (forall i, l <=c i -> i Vg f i = \0c) -> expansion_value (restr f l) b = expansion_value f b. Proof. move=> ef lk p. pose g i := expansion_value (restr f i) b. move: (ef) => [bN kN b2 [fgf df vg]]. have <-: (g k = expansion_value f b) by rewrite /g -df restr_to_domain //. pose r i := g l = g i. have lN := NS_le_nat lk kN. apply: (Nat_induction3 (r:=r) lN kN (erefl _) _ lk (cleR (proj32 lk))). move=> i li ik; rewrite /r => ->. have iN:= NS_lt_nat ik kN. have ik': (csucc i) <=c k by apply /cleSlt0P; fprops. move:(expansion_restr1 ef ik'). set F := (restr f (csucc i)) => eF. rewrite /g (expansion_prop7 eF (proj32 li)). set G := (restr F i). have si: sub (csucc i) (domain f) by rewrite df; exact (proj33 ik'). have ->: restr f i = G by rewrite /G /F double_restr//;apply:(proj33 (cleS iN)). have ->: (Vg F i = \0c). rewrite /F; bw; try apply: p=>//; apply:Nsucc_i =>//. rewrite cprod0l csum0r //; apply: CS_cardinal. Qed. Lemma expansion_prop12 f g b kf kg l n: n <=c kf -> n <=c kg -> l (forall i, n <=c i -> i Vg f i = \0c) -> (forall i, n <=c i -> i Vg g i = \0c) -> (forall i, l i Vg f i = Vg g i) -> expansion f b kf -> expansion g b kg -> (Vg f l) (expansion_value f b) 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 n). set G := (restr g n). move=> eG eF; clear pf pg. move: (ef) => [bN kfN _ [fgf df vf]]. move: (eg) => [_ kgN b2 [fgg dg vg]]. have nN:= NS_le_nat nkf kfN. have lN:= NS_lt_nat ln nN. have pFG: forall i, l i Vg F i = Vg G i. move=> i i1 i2; move: (pfg _ i1 i2). have ii: inc i n by apply /NltP. rewrite /F/G; bw. have vL: (Vg F l) expansion_value (restr F i) b. set gi := fun i => expansion_value (restr G i) b. move: (eF) (eG) => [_ _ _ [fgf df vf]] [_ _ _ [fgg dg vg]]. have <-: (fi n = expansion_value F b) by rewrite /fi -df restr_to_domain. have <-: (gi n = expansion_value G b) by rewrite /gi -dg restr_to_domain. pose r i := (fi i) i li ik ri. have iN:= NS_lt_nat ik nN. have lsin: (csucc i) <=c n by apply /cleSltP. have ssin:= (proj33 lsin). have issi:= (cleS iN). have ssi:= (proj33 issi). have isi:= (Nsucc_i iN). move:(expansion_restr1 eF lsin). move:(expansion_restr1 eG lsin). set f1 := (restr F (csucc i)). set g1 := (restr G (csucc i)). move=> ef1 eg1; move: ri. rewrite /r /fi /gi (expansion_prop7 ef1 (proj32 li)). rewrite (expansion_prop7 eg1 (proj32 li)). set f2 := (restr f1 i). set g2 := (restr g1 i). have si: sub (csucc i) (domain F) by rewrite df. have sj: sub (csucc i) (domain G) by rewrite dg. have ->: (restr F i = f2) by rewrite /f2 /f1 double_restr. have ->: (restr G i = g2) by rewrite /g2 /g1 double_restr. have ->: (Vg f1 i = Vg g1 i). rewrite /f1 /g1; bw; try apply: pFG=>//. apply/cleSlt0P; fprops. have ef2 := (expansion_restr1 eg1 issi). have eg2 := (expansion_restr1 ef1 issi). apply: csum_Mlteq. apply: NS_prod; fprops; apply: (expansion_prop1 ef1); fprops. Qed. Lemma expansion_prop13 f g b kf kg l: kf <=c l -> l expansion f b kf -> expansion g b kg -> Vg g l <> \0c -> (expansion_value f b) le1 le2 ef eg vnz. apply: (@clt_leT (b ^c kf)); first apply: (expansion_prop9 ef). move: eg => [bN bK b2 [fgf df vg]]. rewrite /expansion_value /csumb. set F:= Lg _ _. have fgF: fgraph F by rewrite /F;fprops. have dF: domain F = 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 /NltP. 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)). have ldg: inc l (domain g) by rewrite df; apply /NltP. have bnz: b<> \0c by move=>h; rewrite h in b2; case: (clt0 b2). apply:cleT; rewrite /F; bw. apply: (@cleT (b ^c l)); first apply: cpow_Mlele; fprops. rewrite cprodC;apply: cprod_M1le; fprops. Qed. Lemma expansion_prop14 f g b kf kg: expansion f b kf -> expansion g b kg -> (expansion_value f b) (exists l, [/\ kf <=c l, l \0c]) \/ ( exists l n, [/\ n <=c kf, n <=c kg, l i Vg f i = \0c), (forall i, n <=c i -> i Vg g i = \0c) , (forall i, l i Vg f i = Vg g i) & (Vg f l) ef eg lt. have kfN:natp kf by move: ef => [_ h _]. have kgN:natp kg by move: eg => [_ h _]. have [n [nf ng nfg]]: exists n, [/\ n <=c kf, n <=c kg & (n = kf \/ n = kg)]. case: (NleT_ee kfN kgN)=> aux; [exists kf | exists kg];split;fprops. case: (p_or_not_p (forall i, n <=c i -> i Vg g i = \0c)); last first. move=> h. have [i [ni ik Vz]]: (exists i, [/\ n <=c i, i \0c]). ex_middle h'; case: h => i i1 i2; ex_middle h''; case h'; exists i => //. left; exists i; split => //. case: nfg; [by move=> <- | move=> nk; case:(cltNge ik); ue ]. move=> pB; right. case: (p_or_not_p (forall i, n <=c i -> i Vg f i = \0c)); last first. move=> h. have [i [ni ik Vz]]: (exists i, [/\ n <=c i, i \0c]). ex_middle h'; case: h => i i1 i2; ex_middle h''; case h'; exists i => //. have fi: kg <=c i. case: nfg; [ move => nk; case: (cltNge ik); ue | by move=> <-]. by move: (expansion_prop13 fi ik eg ef Vz) =>[ /(cltNge lt)]. move=> pA. have nN: natp n by case: nfg; move=> -> //. move: (ef) (eg) => [bN bK b2 [fgf df vf]][_ _ _ [fgg dg vg]]. have pC: exists2 l, l (Vg g l). have hf:= (expansion_restr2 ef nf pA). have hg:= (expansion_restr2 eg ng pB). ex_middle bad. have eq: (restr f n = restr g n). have s1: sub n (domain g) by rewrite dg; apply: (proj33 ng). have s2: sub n (domain f) by rewrite df; apply: (proj33 nf). have drf: (domain (restr f n) = n) by bw. have drg: (domain (restr g n) = n) by bw. apply: fgraph_exten; fprops; first ue. rewrite drf => x xdf; bw. ex_middle nx; case: bad; exists x => //. by move: xdf => /(NltP nN). move: lt;rewrite -hf -hg eq; move => [_ ne]; case: ne; reflexivity. have [l [lp ln Vl]]: exists l, [/\ (forall i, l i Vg f i = Vg g i), l (Vg g l)]. set z:= Zo Nat (fun l => l Vg g l). have nz: nonempty z. move: pC => [l lp]; exists l; apply: Zo_i => //; apply: (NS_lt_nat lp nN). have pa: (forall a, inc a z -> cardinalp a) by move=> a /Zo_P [aN _ ]; fprops. have [wor sr]:= (wordering_cle_pr pa). have tor := (worder_total wor). have zc: sub z (Nint n) by move=> t /Zo_P [_ [p1 _]]; apply /NintP. have fsz: finite_set z by apply: (sub_finite_set zc); apply: finite_Nint. have sw: sub z (substrate (graph_on cardinal_le z)) by rewrite sr; fprops. have or := proj1 wor. move: (finite_subset_torder_greatest tor fsz sw nz)=> [l []]. aw; move=> lz lp; exists l. move: (lz); move => /Zo_P [lN [ln Vl]]; split => //. move=> i li lin; ex_middle h. have iN:= NS_lt_nat lin nN. have iz: inc i z by apply: Zo_i => //. by move: (iorder_gle1 (lp _ iz)) => /graph_on_P1 [_ _ /(cltNge li)]. exists l; exists n; split => //. have p1: cardinalp (Vg f l). have ldf: (inc l (domain f)). rewrite df; apply /NltP => //; apply:clt_leT ln nf. exact: (proj31_1 (vf _ ldf)). have p2: cardinalp (Vg g l). have ldf: (inc l (domain g)). rewrite dg; apply /NltP => //; apply:clt_leT ln ng. exact: (proj31_1 (vg _ ldf)). case: (cleT_el p2 p1) => // h. have p3: (Vg g l) //; apply: nesym. have lp' : forall i, l i Vg g i = Vg f i. by move=> i i1 i2; symmetry;move: (lp _ i1 i2). case: (cltNge lt (proj1(expansion_prop12 ng nf ln pB pA lp' eg ef p3))). Qed. Lemma expansion_prop15 f g b n: expansion f b n -> expansion g b n -> ( (expansion_value f b) exists k, [/\ k i Vg f i = Vg g i)]). Proof. move => ha hb; split. case/(expansion_prop14 ha hb); first by move => [l [sa /(cleNgt sa) sb _]]. move => [l [m [hc hd he [hf hi hj hk]]]]; exists l; split => //. apply:clt_leT he hc. move => i la lb; case: (cleT_el (proj31 hc) (proj32_1 la)) => lc. rewrite hf // hi //. by apply: hj. move => [k [hc hd he]]. have nn := (cleR (proj32_1 hc)). by apply:(expansion_prop12 nn nn hc) he ha hb hd => i la /(cleNgt la). Qed. Definition exp_boundary f k := (k = \0c \/ (k <> \0c /\ Vg f (cpred k) <> \0c)). Definition expansion_of f b k a := expansion f b k /\ expansion_value f b = a. Definition expansion_normal_of f b k a := expansion_of f b k a /\ (exp_boundary f k). Definition sub_fgraphs A B := unionf (powerset A) (gfunctions ^~ B). Lemma sub_fgraphsP A B f: inc f (sub_fgraphs A B) <-> exists2 C, sub C A & inc f (gfunctions C B). Proof. split. by move/setUf_P => [z /setP_P zx h ] ; exists z. move => [C /setP_P ca cb]; apply /setUf_P; ex_tac. Qed. Lemma expansion_bounded1 f k b : expansion f b k -> inc f (sub_fgraphs Nat b). Proof. move => [bN kn _ [pd pe pf]]. apply /sub_fgraphsP; exists k; first by move => t; apply:(NS_inc_nat kn). apply/gfunctions_P2; split => // t/(range_gP pd) [x /pf xdf ->]. apply /(oltP (OS_nat bN)); exact:(oclt xdf). Qed. Section TheExpansion. Variable b: Set. Hypothesis bN: natp b. Hypothesis bp: \1c natp a -> a exists f, expansion_of f b k a. Proof. move=> kN; move: k kN a. apply: Nat_induction. rewrite cpowx0 => c cN c1. exists (Lg emptyset (fun _ => \0c)); hnf; bw; split. split;fprops; split; fprops. by bw. by bw; move=> i /in_set0. rewrite /expansion_value/csumb; bw; rewrite csum_trivial; bw. by move: c1; rewrite - succ_zero; move / (cltSleP NS0) => /cle0 ->. move=> n nN pn c cN cp. set (b0:= b ^c n). have b0N: natp b0 by rewrite /b0; fprops. have Bz: (b0 <> card_zero). have [_ /nesym bnz]:=(clt_ltT clt_01 bp). apply: (cpow_nz bnz). move: (cdivision_exists cN b0N Bz) => [q [r [qN rN [aux lt]]]]. rewrite /b0 in lt. move: (pn _ rN lt) => [f [ise ev]]. have p1: (b0 *c q) qb. move: (expansion_prop8 ise qN qb). set F:= (Lg _ _). move=> [s1 s2]; exists F;split => //. by rewrite s2 ev aux csumC /b0. Qed. Lemma expansion_exists2 a: natp a -> exists k f, expansion_of f b k a. Proof. move=> aN; exists a. have [f pa]:exists f, expansion_of f b a a. by apply: expansion_exists1=> //; apply: cpow_M1lt; fprops. by exists f. Qed. Lemma expansion_exists3 a: natp a -> exists k f, expansion_normal_of f b k a. Proof. move=> aN; move:(expansion_exists2 aN) => [k [f [pa pb]]]. move: (pa) => [ha hb hc hd]. move:(hd) => [he hf hg]. set A:= Zo Nat(fun l => l <=c k /\ forall i, l <=c i -> i Vg f i = \0c). have pc: forall l, inc l A -> expansion_of (restr f l) b l a. move => l /Zo_hi [lk lp]. have lN := (NS_le_nat lk hb). split; last by rewrite (expansion_restr2 pa lk lp) pb. split => //; bw; split => //; fprops => i id; bw. move/(NltP lN):id => il; have ik := (clt_leT il lk). by apply: hg; rewrite hf; apply/(NltP hb). have neA: nonempty A. by exists k;apply: Zo_i => //; split; fprops => i ia /(cleNgt ia). have AN: sub A Nat by apply: Zo_S. case:(Nat_wordered AN neA). by move/pc => h;exists \0c, (restr f \0c); split => //; left. move=> [l [lN slA naA]]. move: (pc _ slA) => h. have sa:= (Nsucc_i lN). exists (csucc l), (restr f (csucc l)); split => //; right. rewrite (cpred_pr2 lN); split; [by apply: succ_nz | bw => fz]. move/Zo_hi:slA => [sc sd]. case naA; apply:(Zo_i lN); split; first exact:(cleT (cleS lN) sc). move => i i1 i2; case (equal_or_not l i) => eil; first by rewrite - eil. by apply: sd => //; apply/(cleSltP lN). Qed. Lemma expansion_unique1 a f k f' k': expansion_normal_of f b k a -> expansion_normal_of f' b k' a -> f = f' /\ k = k'. Proof. move => [[ha hb] hc] [[ha' hb'] hc']. have kN: natp k by move: ha => []. have k'N: natp k' by move: ha' => []. case: (NleT_ell kN k'N) => h. + rewrite - h in ha'; rewrite - hb' in hb; split => //. exact: (expansion_unique ha ha' hb). + case: hc'; first by move => e1; rewrite e1 in h; case: (clt0 h). move => [e1 e2]. move: (cpred_pr k'N e1) => [sa sb]. have k1: k <=c (cpred k') by apply /(cltSleP sa); rewrite - sb. have k2: (cpred k') e1; rewrite e1 in h; case: (clt0 h). move => [e1 e2]. move: (cpred_pr kN e1) => [sa sb]. have k1: k' <=c (cpred k) by apply /(cltSleP sa); rewrite - sb. have k2: (cpred k) expansion_normal_of z b (cardinal (domain z)) a) (sub_fgraphs Nat b). Lemma the_expansion_pr a (z := the_expansion a): natp a -> expansion_normal_of z b (cardinal (domain z)) a. Proof. pose p z:= expansion_normal_of z b (cardinal (domain z)) a. set E := (sub_fgraphs Nat b). move => aN. have sa: (exists2 x, inc x E & p x). move: (expansion_exists3 aN) => [k [f etc]]. have cdf: k = cardinal (domain f). by move: etc => [[[_ hb _ [_ -> _]] _] _]; rewrite (card_nat hb). move: (expansion_bounded1 (proj1 (proj1 etc))) => xEZ; ex_tac. by rewrite /p - cdf. have sb: singl_val2 (inc^~ E) p. move => f1 f2 _ pf1 _ pf2; exact: (proj1 (expansion_unique1 pf1 pf2)). by move: (select_pr sa sb) => []. Qed. Lemma the_expansion_zero: the_expansion \0c = emptyset. Proof. move: (the_expansion_pr NS0) => sa. have hh: exp_boundary emptyset \0c by left. suff: expansion_normal_of emptyset b \0c \0c. move => sb; exact (proj1 (expansion_unique1 sa sb)). have H: expansion_value emptyset b = \0c. rewrite /expansion_value domain_set0; apply: csum_trivial; bw. split; fprops;split => //; split;fprops; split; bw => //. + apply: fgraph_set0. + by move => i /in_set0. Qed. Lemma the_expansion_digit a: a <> \0c -> a the_expansion a = singleton (J \0c a). Proof. move => abz alb. have aN :=(NS_lt_nat alb bN). have n1:= NS1. move: (the_expansion_pr aN) => sa. move: (simple_fct2 \0c a); set f := singleton (J \0c a). move => [ra rb rc rd re]. have rf:Vg f \0c *c b ^c \0c = a by rewrite rd cpowx0 (cprod1r (CS_nat aN)). have rg: expansion_value f b = a. by rewrite /expansion_value rb csum_trivial3 rf (card_nat aN). suff: expansion_normal_of f b \1c a. move => sb; exact (proj1 (expansion_unique1 sa sb)). split; last by right; split; [ apply: card1_nz | by rewrite cpred1 rd]. split => //; split => //; rewrite rb; split => //. move => i /set1_P ->; ue. Qed. Definition the_contraction a := csum (the_expansion a). Lemma the_contraction_zero: the_contraction \0c = \0c. Proof. by rewrite /the_contraction the_expansion_zero csum_trivial // domain_set0. Qed. Lemma the_contraction_digit a: a the_contraction a = a. Proof. move => lab. case: (equal_or_not a \0c) => anz. by rewrite anz; exact:the_contraction_zero. rewrite /the_contraction - {2} (card_card (proj31_1 lab)) /the_contraction. move: (simple_fct2 \0c a) => [_ _ _ _ re]. by rewrite (the_expansion_digit anz lab) re -/(csumb _ _ ) csum_trivial3. Qed. Lemma the_contraction_non_digit a: b <=c a -> natp a -> the_contraction a pa pb; rewrite /the_contraction. move: (the_expansion_pr pb). set f := (the_expansion a);move => [[pc pd] pe]. case: pe. move => /card_nonempty cdf; rewrite csum_trivial //. exact: (clt_leT (clt_ltT clt_01 bp) pa). move: (pc) => [pg ph pi [pk1 pk2 pk3]] [pl pm]. move: (cpred_pr ph pl); set k1:= cpred _; move => [pn po]. move:pm; rewrite po; rewrite (cpred_pr2 pn) => pm. set g := (Lg (domain f) (fun i => Vg f i *c b ^c i)). have fsdf: finite_set (domain f) by rewrite /finite_set po; fprops. have dfdg: domain f = domain g by rewrite /g; bw. have qa:finite_int_fam f. split => //; move => i /pk3 h; apply:(NS_lt_nat h pg). have qb:finite_int_fam g. rewrite /g;split; last by bw. hnf; bw => i idf; bw; move: (proj1 qa _ idf) => sa; apply/NS_prod => //. apply /NS_pow => //. by move: idf; rewrite pk2 po; move/(NleP pn) => le; move:(NS_le_nat le pn). rewrite - pd /expansion_value /csumb. have bsp:= (clt_ltT (clt_01) pi). apply: (finite_sum_lt qa qb); bw. rewrite /g; move => i idf; bw; apply: cprod_M1le. exact: (CS_nat (proj1 qa _ idf)). by apply: cpow_nz => bz; case: (proj2 bsp). have kh1:inc k1 (domain f). by rewrite pk2; apply/(NltP ph); rewrite po; apply:cltS. have nk1: natp (Vg f k1) by apply(proj1 qa _ kh1). have nk3: natp (b ^c k1) by fprops. case: (equal_or_not k1 \0c) => k1z. have ddf: domain f = singleton \0c. by rewrite pk2 po k1z succ_zero. have zdf: inc \0c (domain f) by rewrite ddf; fprops. have aux:= (CS_nat (proj1 qa _ zdf)). have rs: Vg f \0c *c b ^c \0c = Vg f \0c. by rewrite cpowx0 (cprod1r aux). case:(cleNgt pa);move: pd (pk3 _ zdf). by rewrite /expansion_value ddf (csum_trivial3) rs (card_card aux) => ->. have pp:= (clt_leT pi (cpow_Mle1 (CS_nat pg) k1z)). exists k1 => //; rewrite /g; bw; apply:cprod_M1lt => //. Qed. Lemma the_contraction_non_zero a: natp a -> a <> \0c -> the_contraction a <> \0c. Proof. move => aN ap; rewrite /the_contraction. move: (the_expansion_pr aN). set f := (the_expansion a);move => [[pc pd] pe]. case: pe. move => /card_nonempty cdf; move: ap ; rewrite - pd. rewrite /expansion_value/csumb csum_trivial //; bw. move: (pc) => [pg ph pi [pk1 pk2 pk3]] [pl pm] sz. move: (cpred_pr ph pl); set k1:= cpred _; move => [pn po]. have cff:cardinal_fam f by move => i /pk3 [[]]. have kh1:inc k1 (domain f). by rewrite pk2; apply/(NltP ph); rewrite po; apply:cltS. by move: (csum_increasing6 cff kh1); rewrite sz => /cle0. Qed. Definition contraction_rec a := induction_defined (the_contraction) a. Definition contraction_rep a := Vf (contraction_rec a) a. Lemma contraction_rec0 a: Vf (contraction_rec a) \0c = a. Proof. exact: (proj43 (induction_defined_pr (the_contraction) a)). Qed. Lemma contraction_rec_succ a n: natp n -> Vf (contraction_rec a) (csucc n) = the_contraction (Vf (contraction_rec a) n). Proof. exact: (proj44 (induction_defined_pr (the_contraction) a) n). Qed. Lemma NS_contraction_rec a n: natp a -> natp n -> natp (Vf (contraction_rec a) n). Proof. move => aN nN; move: n nN a aN; apply: Nat_induction. by move => a aN; rewrite contraction_rec0. move => n nN Hrec a /Hrec aN; rewrite (contraction_rec_succ _ nN). case: (NleT_el bN aN) => cnb. by move:(the_contraction_non_digit cnb aN) => /(NS_lt_nat); apply. by rewrite (the_contraction_digit cnb). Qed. Lemma contraction_rec_non_zero a n: natp n -> natp a -> a <> \0c -> (Vf (contraction_rec a) n) <> \0c. Proof. move => nN; move: n nN a; apply:Nat_induction. by move => a _ anz; rewrite contraction_rec0. move => n nN Hrec a aN anz; rewrite (contraction_rec_succ _ nN). apply:(the_contraction_non_zero (NS_contraction_rec aN nN) (Hrec _ aN anz)). Qed. Lemma contraction_rec_succ' a n: natp n -> Vf (contraction_rec a) (csucc n) = Vf (contraction_rec (the_contraction a)) n. Proof. move => nN; move: n nN a; apply: Nat_induction. by move => a; rewrite (contraction_rec_succ _ NS0) ! contraction_rec0. move => n nN Hrec a. by rewrite (contraction_rec_succ _ (NS_succ nN)) Hrec contraction_rec_succ. Qed. Lemma contraction_rec_succ'' a n m: natp n -> natp m -> Vf (contraction_rec a) (n +c m) = Vf (contraction_rec (Vf (contraction_rec a) n)) m. Proof. move => nN mN; move: m mN n nN. apply: Nat_induction. move => n nN; rewrite contraction_rec0 csum0r; fprops. move => m mN Hrec n nN. rewrite (csum_nS _ mN) (contraction_rec_succ _ (NS_sum nN mN)). rewrite (Hrec _ nN) contraction_rec_succ //. Qed. Lemma contraction_rep_dig a : natp a -> contraction_rep a forall c, c <=c a -> contraction_rep c H a aN; exact: (H a aN a (cleR (CS_nat aN))). apply: Nat_induction. move => c /cle0 ->; rewrite /contraction_rep contraction_rec0. exact:(clt_ltT (clt_01) bp). have H: forall n, natp n -> forall a, a Vf (contraction_rec a) n = a. apply: Nat_induction; first by move => a _; rewrite contraction_rec0. move => n nN Hrec a ab; rewrite (contraction_rec_succ' _ nN). rewrite (the_contraction_digit ab); exact: Hrec. move => n nN Hrec c csn; case: (equal_or_not c (csucc n)); last first. move => h;move /(cltSleP nN): (conj csn h); exact: Hrec. have snN:=(NS_succ nN). move => ->; case: (NleT_el bN snN) => cnb; last first. by rewrite/contraction_rep (H _ snN _ cnb). move:(the_contraction_non_digit cnb snN) => /(cltSleP nN). rewrite /contraction_rep (contraction_rec_succ' _ nN). set x := the_contraction (csucc n) => xn. move: (NS_le_nat xn nN) (NS_diff x nN) (Hrec _ xn) => ha hb hc. rewrite -(cdiff_pr xn) (contraction_rec_succ'' _ ha hb). by rewrite -/(contraction_rep _) (H _ hb _ hc). Qed. Lemma contraction_rep_non_zero a: natp a -> a <> \0c -> (contraction_rep a) <> \0c. Proof. by move => pa pb; apply:(contraction_rec_non_zero pa pa pb). Qed. End TheExpansion. (** Equality modulo n *) Definition eqmod B a b:= a %%c B = b %%c B. Section ModuloProps. Variable B: Set. Hypothesis BN: natp B. Hypothesis Bnz: B <> \0c. Lemma eqmod_equivalence (R:= graph_on (eqmod B) Nat): equivalence R /\ substrate R = Nat. Proof. split; last by apply: graph_on_sr => a. apply: equivalence_from_rel; split. by move => a b ab. by move => b a c; rewrite /eqmod => -> ->. Qed. Lemma crem_prop a b: natp a -> natp b -> eqmod B ((B *c a) +c b) b. Proof. move=> aN bN; rewrite /eqmod. move: (cdivision bN BN Bnz). set q := b %/c B; set r := b %%c B. move=> [q1N r1N [aeq r1p]]. rewrite aeq csumA - cprodDl. set q2:= (a +c q). have q2N: natp q2 by rewrite /q2; apply: NS_sum. set A:= ((B *c q2) +cr). have dp: (cdivision_prop A B q2 r) by split;[apply: refl_equal | done]. move: (cquorem_pr (NS_sum (NS_prod BN q2N) r1N) BN q2N r1N dp). by move=> [_ h]; symmetry. Qed. Lemma crem_sum a b: natp a -> natp b -> eqmod B (a +c b) ((a %%c B) +c (b %%c B)). Proof. move=> aN bN. move: (cdivision aN BN Bnz) (cdivision bN BN Bnz). rewrite /cdivision_prop. set q1:= a %/c B; set q2:= b %/c B; set r1:= a %%c B; set r2:= b %%c B. move=> [q1N r1N [aeq r1p]][q2N r2N [beq r2p]]. rewrite aeq beq. set t := _ +c _. have ->: t= (B *c (q1 +c q2)) +c (r1 +c r2). rewrite cprodDl csumA. set (s1:= B *c q1); set (s2:= B *c q2). by rewrite /t (csum_permute24) -/s1 -/s2 csumA. apply:(crem_prop (NS_sum q1N q2N) (NS_sum r1N r2N)). Qed. Lemma crem_prod a b: natp a -> natp b -> eqmod B (a *c b) ((a %%c B) *c (b %%c B)). Proof. move=> aN bN. move: (cdivision aN BN Bnz) (cdivision bN BN Bnz). set q1:= a %/c B; set q2:= b %/c B; set r1:= a %%c B; set r2:= b %%c B. rewrite /cdivision_prop. move=> [q1N r1N [aeq r1p]][q2N r2N [beq r2p]]. rewrite aeq beq cprodDl(cprodC B q2) cprodA (cprodC _ B). set v := ((B *c q1) +c r1) *c q2. rewrite cprodDr - cprodA csumA - cprodDl. apply: crem_prop ; [apply: NS_sum | ]; apply: NS_prod => //; ue. Qed. Lemma eqmod_sum a b a' b': natp a -> natp b -> natp a' -> natp b' -> eqmod B a a' -> eqmod B b b' -> eqmod B (a +c b) (a' +c b'). Proof. move=> aN bN a'N b'N; rewrite /eqmod => e1 e2. rewrite (crem_sum aN bN) e1 e2 (crem_sum a'N b'N); reflexivity. Qed. Lemma eqmod_prod a b a' b': natp a -> natp b -> natp a' -> natp b' -> eqmod B a a' -> eqmod B b b' -> eqmod B (a *c b) (a' *c b'). Proof. move=> aN bN a'N b'N e1 e2. rewrite /eqmod in e1 e2 |- *. rewrite (crem_prod aN bN) (crem_prod a'N b'N) e1 e2;reflexivity. Qed. Lemma eqmod_rem a: natp a -> eqmod B a (a %%c B). Proof. move=> aN; rewrite {1} (cdiv_pr aN BN); apply: crem_prop; fprops. Qed. Lemma eqmod_succ a a': natp a -> natp a' -> eqmod B a a' -> eqmod B (csucc a) (csucc a'). Proof. move=> aN a'N e1. rewrite !csucc_pr4; fprops; apply: eqmod_sum => //; fprops. Qed. Lemma eqmod_pow1 a n: natp a -> natp n -> eqmod B a \1c -> eqmod B (a ^c n) \1c. Proof. move=> aN nN h; move: n nN. apply: Nat_induction; first by rewrite cpowx0. move=> n nN h1. move: (eqmod_prod (NS_pow aN nN) aN NS1 NS1 h1 h). rewrite (cpow_succ _ nN) (cprod1r); fprops. Qed. Lemma eqmod_pow2 a b n: natp a -> natp b -> natp n -> eqmod B a \1c -> eqmod B (b *c (a ^c n)) b. Proof. move=> aN bN nN h. move: (eqmod_pow1 aN nN h) => h2. have aux: eqmod B b b by []. move: (eqmod_prod bN (NS_pow aN nN) bN NS1 aux h2). rewrite cprod1r; fprops. Qed. Lemma eqmod_pow3 f b k: expansion f b k -> eqmod B b \1c -> eqmod B (expansion_value f b) (csum f). Proof. move=> ep b1. have kN: natp k by move: ep => [bN kN _]. move: k kN f ep. apply: Nat_induction. move=> g [bN _ b2 [fgf df _]]. rewrite /expansion_value/csumb df !csum_trivial //; bw. move=> n nN pn g eg. have cn: (cardinalp n) by fprops. rewrite (expansion_prop7 eg cn). move: (expansion_prop5 eg cn) => er. move: (eg) => [bN _ _ [fgg dg _]]. move: (NS_succ nN) => snN. have si: sub n (domain g) by rewrite dg; apply (proj33 (cleS nN)). have ->: (csum g = (csum (restr g n)) +c (Vg g n)). pose h w := \0c +c (Vg g w). have hp: forall x, inc x (domain g) -> h x = Vg g x. move=> x; rewrite dg; move /(NltP snN) => p1. move: (expansion_prop1 eg p1) => p2. rewrite /h; aw; fprops. move: (induction_on_sum h nN); rewrite /csumb. have ->: h n = Vg g n by apply: hp; rewrite dg; apply:Nsucc_i. have ->: (Lg (csucc n) h = g). apply: fgraph_exten; fprops; first by symmetry;bw. bw; move=> x xd /=; bw; apply: hp; ue. have -> //: (Lg n h = (restr g n)). apply: Lg_exten => x xb; apply: (hp _ (si _ xb)). have p1: natp (Vg g n) by apply: (expansion_prop1 eg (cltS nN)). have p2: inc ((Vg g n) *c (b ^c n)) Nat. apply: (NS_prod p1 (NS_pow bN nN)). have p3: inc (csum (restr g n)) Nat. apply: finite_sum_finite_aux; last by exact. split => //. move=> i; rewrite dg; move /(NltP snN). apply: (expansion_prop1 eg). by rewrite dg; apply: finite_set_nat. apply: (eqmod_sum (expansion_prop3 er) p2 p3 p1 (pn _ er)). apply: (eqmod_pow2 bN p1 nN b1). Qed. End ModuloProps. Lemma crem_succ a B: natp a -> natp B -> \1c (csucc a) %%c B = (csucc (a %%c B)) %%c B. Proof. move => aN BN Bp. have Bnz: B <> \0c by move => h; apply:(@clt0 \1c); rewrite - h. move:(crem_sum BN Bnz aN NS1). by rewrite - (crem_small BN Bp) - (Nsucc_rw aN) - (Nsucc_rw (NS_rem aN BN)). Qed. Definition card_five := csucc card_four. Definition card_nine := \3c *c \3c. Definition card_ten := card_five +c card_five. Notation "\10c" := card_ten. Notation "\9c" := card_nine. Notation "\5c" := card_five. Lemma card3_nz: \3c <> \0c. Proof. by rewrite /card_three; apply: succ_nz. Qed. Lemma card9_nz: \9c <> \0c. Proof. by apply: (cprod2_nz card3_nz card3_nz). Qed. Lemma NS5 : natp \5c. Proof. apply: (NS_succ NS4). Qed. Lemma NS9 : natp \9c. Proof. apply: (NS_prod NS3 NS3). Qed. Lemma NS10 : natp \10c. Proof. apply: (NS_sum NS5 NS5). Qed. Lemma card_sum_3_2: \3c +c \2c = \5c. Proof. rewrite /card_five (Nsucc_rw NS4) /card_four (Nsucc_rw NS3). by rewrite - csumA card_two_pr. Qed. Lemma card_prod_3_3: \10c = csucc \9c. Proof. have aux: forall n, cardinalp n -> (n +c n) +c n = n *c \3c. move=> n cn; rewrite /card_three (Nsucc_rw NS2). rewrite cprodDl. by rewrite (cprod1r cn) cprodC two_times_n. rewrite / \10c - card_sum_3_2 - csum_permute24. set t:= (\3c +c \3c). rewrite csumA -{2} succ_one (csum_nS _ NS1) - csumA - (Nsucc_rw NS2). congr (csucc _);apply: aux; apply: (CS_nat NS3). Qed. Lemma card_mod_10_9: eqmod \9c \10c \1c. Proof. have nnz:= card9_nz. rewrite - succ_zero card_prod_3_3; apply:(eqmod_succ NS9 nnz NS9 NS0). move: (crem_prop NS9 nnz NS1 NS0). by rewrite (cprod1r (CS_nat NS9)) (csum0r (CS_nat NS9)). Qed. Lemma card_mod_10_3: eqmod \3c \10c \1c. Proof. rewrite card_prod_3_3 (Nsucc_rw (NS_prod NS3 NS3)). exact: (crem_prop NS3 card3_nz NS3 NS1). Qed. Lemma cgt10_1: \1c (Vg f i) let g:= (Lg (domain f) (fun i=> (Vg f i) *c (\10c ^c i))) in eqmod \3c (csum g) (csum f). Proof. move=> [p1 p2 p3 p4]. have ep: expansion f \10c k. split => //; [by apply: NS10 | apply:cgt10_1]. exact (eqmod_pow3 NS3 card3_nz ep card_mod_10_3). Qed. Lemma divisibiliy_by_nine f k: expansion_ten f k -> let g:= (Lg (domain f) (fun i=> (Vg f i) *c (\10c ^c i))) in eqmod \9c (csum g) (csum f). Proof. move=> [p1 p2 p3 p4]. have ep: expansion f \10c k. split => //; [by apply: NS10 | apply:cgt10_1]. exact (eqmod_pow3 NS9 card9_nz ep card_mod_10_9). Qed. Lemma eqmod_contraction b a: natp a -> natp b -> b <> \0c -> eqmod b a (the_contraction (csucc b) a). Proof. move => aN bN bnz. have sbN := NS_succ bN. have bg1: \1c [[ha hb] hc]; rewrite - hb. apply:(eqmod_pow3 bN bnz ha). rewrite - succ_zero; apply:(eqmod_succ bN bnz bN NS0). move: (crem_prop bN bnz NS1 NS0). by rewrite (cprod1r (CS_nat bN)) (csum0r (CS_nat bN)). Qed. Lemma eqmod_contraction_rep b a (x := contraction_rep (csucc b) a) (y := a %%c b) : natp a -> natp b -> b <> \0c -> [/\ eqmod b a x, (a = \0c -> x = \0c) & (a <> \0c -> (y = \0c -> x = b) /\ (y <> \0c -> x = y))]. Proof. move => aN bN bnz. have sbN := NS_succ bN. have bg1: \1c eqmod b a (Vf (contraction_rec (csucc b) a) n). apply:Nat_induction; first by rewrite contraction_rec0. move => n nN; rewrite (contraction_rec_succ _ _ nN). set z:= Vf _ _. have zN: natp z by apply: NS_contraction_rec. by move: (@eqmod_contraction b z zN bN bnz); rewrite /eqmod; move => ->. have h: eqmod b a x by apply:hrec. move:(contraction_rep_dig sbN bg1 aN); rewrite -/x. move /(cltSleP bN) => lexb. have xN := NS_le_nat lexb bN. case: (equal_or_not a \0c) => caz. by split => // ha; rewrite /x /contraction_rep ha contraction_rec0. split => // ha. move:(contraction_rep_non_zero sbN bg1 aN ha); rewrite -/x => xnz. case (equal_or_not x b) => xeb. split => //. have cb: cardinalp b by fprops. have cp: \0c //;rewrite cprod1r // csum0r //. move: h; rewrite /eqmod. by rewrite - (proj2(cquorem_pr xN bN NS1 NS0 h2)) -/y. move: h; rewrite /y /eqmod => ->. have h2: cdivision_prop x b \0c x. split => //;rewrite cprod0r csum0l; fprops. rewrite -(proj2(cquorem_pr xN bN NS0 xN h2)); split => //. Qed. Lemma eqmod_contraction_rep9 a (x := contraction_rep \10c a) (y := a %%c \9c) : natp a -> [/\ eqmod \9c a x, (a = \0c -> x = \0c) & (a <> \0c -> (y = \0c -> x = \9c) /\ (y <> \0c -> x = y))]. Proof. move => an; rewrite /x card_prod_3_3. apply:eqmod_contraction_rep => //; [ apply:NS9 | apply: card9_nz]. Qed. (** Even and odd integers; half and double *) Definition evenp n := natp n /\ n %%c \2c = \0c. Definition oddp n := natp n /\ ~ (evenp n). Lemma oddp_alt n: natp n -> (oddp n <-> n %%c \2c = \1c). Proof. move => nN; split => on. move: (cdivision nN NS2 card2_nz) => [ _ mN [_ /clt2]]; case => // h. by case:on => _; rewrite /evenp h => [] []. rewrite /oddp/evenp on; split => // [] [_]; fprops. Qed. Lemma crem_02: \0c %%c \2c = \0c. Proof. exact: (crem_of_zero NS2). Qed. Lemma crem_12: \1c %%c \2c = \1c. Proof. exact:(sym_eq (crem_small NS2 clt_12)). Qed. Lemma crem_22: \2c %%c \2c = \0c. Proof. by move:(cdivides_itself NS2) => []. Qed. Lemma succ_of_even n: evenp n -> oddp (csucc n). Proof. move => [nN en]; apply/(oddp_alt (NS_succ nN)). by rewrite (crem_succ nN NS2 clt_12) en succ_zero crem_12. Qed. Lemma succ_of_odd n: oddp n -> evenp (csucc n). Proof. move =>h; move:(proj1 h)=> nN;move/(oddp_alt nN): h => sa. by split;fprops; rewrite (crem_succ nN NS2 clt_12) sa succ_one crem_22. Qed. Lemma succ_of_evenP n: natp n -> (evenp n <-> oddp (csucc n)). Proof. move => nN; split; first by apply:succ_of_even. move => h;ex_middle h';case: (proj2 h);exact:(succ_of_odd (conj nN h')). Qed. Lemma succ_of_oddP n: natp n -> (oddp n <-> evenp (csucc n)). Proof. move => nN; split; first by apply:succ_of_odd. move => h;case: (p_or_not_p (evenp n)) => //h'. by case:(proj2 (succ_of_even h')). Qed. Lemma even_zero: evenp \0c. Proof. split; [fprops | by rewrite crem_02]. Qed. Lemma odd_one: oddp \1c. Proof. by rewrite - succ_zero; apply (succ_of_even even_zero). Qed. Lemma even_two: evenp \2c. Proof. by rewrite - succ_one; apply (succ_of_odd odd_one). Qed. Lemma csum_of_even a b: evenp a -> evenp b -> evenp (a +c b). Proof. move => [aN ae][bN be]; split; first by fprops. move: (crem_sum NS2 card2_nz aN bN). by rewrite /eqmod ae be (csum0r CS0) crem_02. Qed. Lemma csum_of_even_odd a b: evenp a -> oddp b -> oddp (a +c b). Proof. move => [aN ae] ob; move: (proj1 ob) => bN; move/(oddp_alt bN): ob => bo. apply/(oddp_alt (NS_sum aN bN)); move: (crem_sum NS2 card2_nz aN bN). by rewrite ae bo (csum0l CS1) /eqmod crem_12. Qed. Lemma csum_of_odd a b: oddp a -> oddp b -> evenp (a +c b). Proof. move => oa ob; move: (proj1 ob) => bN; move/(oddp_alt bN): ob => bo. move: (proj1 oa) => aN; move/(oddp_alt aN): oa => ao. split; fprops; move: (crem_sum NS2 card2_nz aN bN). by rewrite ao bo card_two_pr /eqmod crem_22. Qed. Lemma csum_of_evenP n m: evenp n -> natp m -> (evenp (n +c m) <-> evenp m). Proof. move => eN mN; split => h; last by apply:csum_of_even. by ex_middle h'; move: (proj2(csum_of_even_odd eN (conj mN h'))). Qed. Lemma csum_of_oddP n m: oddp n -> natp m -> (evenp (n +c m) <-> oddp m). Proof. move => on mN; split => h; last by apply:csum_of_odd. case: (p_or_not_p (evenp m)) => // h'. by move: (proj2(csum_of_even_odd h' on)); rewrite csumC. Qed. Definition cdouble n := \2c *c n. Definition chalf n := n %/c \2c. Lemma NS_double n: natp n -> natp (cdouble n). Proof. move => h; apply: (NS_prod NS2 h). Qed. Lemma NS_half n: natp (chalf n). Proof. by apply:(NS_quo). Qed. Lemma cdouble0: cdouble \0c = \0c. Proof. by rewrite /cdouble cprod0r. Qed. Lemma even_double n: natp n -> evenp (cdouble n). Proof. move => h; split; first by apply: NS_double. exact: (proj33 (cdivides_pr1 h NS2)). Qed. Lemma odd_succ_double n: natp n -> oddp (csucc (cdouble n)). Proof. by move => /even_double /succ_of_even. Qed. Lemma half_even n: evenp n -> n = cdouble (chalf n). Proof. move => [nN pb]; move: (cdiv_pr nN NS2); rewrite pb;aw; fprops. Qed. Lemma half_odd n: oddp n -> n = csucc (cdouble (chalf n)). Proof. move => on; move: (proj1 on) => nN; move/(oddp_alt nN): on => on. move: (cdiv_pr nN NS2). by rewrite on Nsucc_rw //; apply: NS_double; apply:NS_half. Qed. Lemma cdouble_halfV n: natp n -> n = cdouble (chalf n) \/ n = csucc (cdouble (chalf n)). Proof. move => nN; case:(p_or_not_p (evenp n)) => h. by left; exact: (half_even h). right; exact: (half_odd (conj nN h)). Qed. Lemma even_half n: natp n -> chalf (cdouble n) = n. Proof. move => nN; exact (cdivides_pr4 NS2 nN card2_nz). Qed. Lemma odd_half n: natp n -> chalf (csucc (cdouble n)) = n. Proof. move=> nN; move:(NS_double nN) => n2N. have h: cdivision_prop (csucc (cdouble n)) \2c n \1c. split; [ by rewrite (Nsucc_rw n2N) | exact: clt_12]. symmetry; exact: (proj1 (cquorem_pr (NS_succ n2N) NS2 nN NS1 h)). Qed. Lemma half0: chalf \0c = \0c. Proof. by rewrite -{1} cdouble0(even_half NS0). Qed. Lemma half1: chalf \1c = \0c. Proof. by rewrite - succ_zero -{1} cdouble0 (odd_half NS0). Qed. Lemma half2: chalf \2c = \1c. Proof. by rewrite - (cprod1r CS2) (even_half NS1). Qed. Lemma double_sum a b: cdouble a +c cdouble b = cdouble (a +c b). Proof. by rewrite /cdouble cprodDl. Qed. Lemma double_prod a b: a *c cdouble b = cdouble (a *c b). Proof. by rewrite /cdouble cprodA cprodA (cprodC a). Qed. Lemma double_succ a: natp a -> cdouble (csucc a) = csucc (csucc (cdouble a)). Proof. move => aN; move:(NS_double aN) => dN. rewrite (Nsucc_rw aN) - double_sum {2} /cdouble (cprod1r CS2) - card_two_pr. by rewrite csumA -(Nsucc_rw dN) - (Nsucc_rw (NS_succ dN)). Qed. Lemma cdouble_pow2 n: natp n -> cdouble(\2c ^c n) = \2c ^c (csucc n). Proof. by move => h;rewrite (cpow_succ _ h) cprodC. Qed. Lemma half_succ n : natp n -> chalf (csucc (csucc n)) = csucc (chalf n). Proof. move => nN; move: (NS_half n) => hN; move: (NS_succ hN) => shN. case: (cdouble_halfV nN) => ->; rewrite - (double_succ hN). by rewrite ! even_half. by rewrite ! odd_half. Qed. Lemma double_inj a b: natp a -> natp b -> cdouble a = cdouble b -> a = b. Proof. by move => aN bN; move/(cprod_eq2l NS2 aN bN card2_nz). Qed. Lemma double_monotone a b: natp a -> natp b -> (cdouble a <=c cdouble b <-> a <=c b). Proof. move => pa pb; rewrite /cdouble. split; [apply:(cprod_le2l NS2 pa pb card2_nz) | apply: cprod_Meqle]. Qed. Lemma double_monotone2 a b: natp a -> natp b -> (cdouble a a aN bN; split. move => [/(double_monotone aN bN) sa sb]; split => // h; case: sb; ue. move =>[/(double_monotone aN bN) sa sb]; split => //. by move /(double_inj aN bN). Qed. Lemma double_monotone3 a b: natp a -> natp b -> (csucc (cdouble a) a aN bN. move:(cleSltP (NS_succ (NS_double aN)) (cdouble b)); rewrite -(double_succ aN). move:(iff_trans (double_monotone (NS_succ aN) bN) (cleSltP aN b)). move => ha hb; exact (iff_trans (iff_sym hb) ha). Qed. Lemma half_monotone n m: natp n -> natp m -> n <=c m -> chalf n <=c chalf m. Proof. move => nN mN. move:(NS_half n) (NS_half m) => hnN hmN. case: (cdouble_halfV nN) => {1} ->;case: (cdouble_halfV mN) => {1} ->. + by move/(double_monotone hnN hmN). + move/(cltSleP (NS_succ (NS_double hmN))); rewrite - (double_succ hmN). by move/(double_monotone2 hnN (NS_succ hmN)); move/(cltSleP hmN). + by move/(cleT (cleS (NS_double hnN))) /(double_monotone hnN hmN). + move/(cleSSP (CS_nat(NS_double hnN)) (CS_nat (NS_double hmN))). by move/(double_monotone hnN hmN). Qed. Lemma half_monotone2 n m: natp n -> natp m -> n <=c (chalf m) -> cdouble n <=c m. Proof. move => nN mN; move /(double_monotone nN (NS_half m)) => sa. case: (cdouble_halfV mN) => -> //. exact:(cleT sa (cleS (NS_double (NS_half m)))). Qed. Lemma double_le_odd1 p k: natp k -> natp p -> cdouble p <=c csucc (cdouble k) -> p <=c k. Proof. move => kN pN le1; case:(NleT_el pN kN) => // /(cleSltP kN). move/(double_monotone (NS_succ kN) pN);rewrite (double_succ kN) => le2. case: (cleNgt le2 (cle_ltT le1 (cltS (NS_succ (NS_double kN))))). Qed. Lemma double_le_odd2 p k: natp k -> natp p -> csucc (cdouble k) <=c cdouble p -> csucc k <=c p. Proof. move => kN pN; move/cleSS. rewrite - (double_succ kN); apply:(double_le_odd1 pN (NS_succ kN)). Qed. Lemma cle_n_doublen n: natp n -> n <=c cdouble n. Proof. move => nN. rewrite /cdouble two_times_n; apply:(csum_M0le _ (CS_nat nN)). Qed. Lemma cle_Sn_doublen n: natp n -> n <> \0c -> csucc n <=c cdouble n. Proof. move => nN /(cpred_pr nN) [sa ->]. rewrite (double_succ sa);apply: cleSS; apply: cleSS; apply:(cle_n_doublen sa). Qed. Lemma clt_n_doublen n: natp n -> n <> \0c -> n nN /(cle_Sn_doublen nN) /(cleSltP nN). Qed. Lemma cle_halfn_n n: natp n -> chalf n <=c n. Proof. move => nN. move:(cle_n_doublen (NS_half n)) => H. case:(cdouble_halfV nN); move => {2} -> //. apply: (cleT H (cleS (NS_double (NS_half n)))). Qed. Lemma cle_halfSn_n n: natp n -> n <> \0c -> chalf (csucc n) <=c n. Proof. move => nN nz. move:(cpred_pr nN nz) => [sa sb]; rewrite sb (half_succ sa). by move/(cleSSP (CS_nat (NS_half _)) (CS_nat sa)): (cle_halfn_n sa). Qed. Lemma double_nz n: natp n -> n <> \0c -> (cdouble n <> \0c /\ cdouble n <> \1c). Proof. move => nN nz; split; first by apply: (cprod2_nz card2_nz nz). by move => h; move:(proj2 (odd_one)) (even_double nN); rewrite -/(cdouble n) h. Qed. Lemma doubleS_nz n: natp n -> n <> \0c -> (csucc (cdouble n) <> \0c /\ csucc (cdouble n) <> \1c). Proof. move => nN nz; split; first by apply: succ_nz. rewrite - succ_zero; move/(succ_injective1 (CS_nat (NS_double nN)) CS0). apply: (cprod2_nz card2_nz nz). Qed. Lemma even_odd_dichot n (m := csucc n): natp n -> [\/ m = \1c, (m = cdouble (chalf m) /\ chalf m <=c n) | [/\ m = csucc (cdouble (chalf m)), (chalf m) <=c n & csucc (chalf m) <=c n]]. Proof. move => nN; rewrite /m. have mN:= NS_succ nN. have hN:= NS_half m. case: (equal_or_not n \0c) => nz; first by constructor 1; rewrite nz succ_zero. have aa:=(cle_halfSn_n nN nz). case: (cdouble_halfV mN) => mv; first by constructor 2. constructor 3; split => //; apply/(cleSltP hN). apply/(double_monotone2 hN nN) /(cleSltP (NS_double hN)). by rewrite - mv; apply:(cle_Sn_doublen nN nz). Qed. Lemma fusc_induction (p: property): p \0c -> p \1c -> (forall k, natp k -> p k -> p (cdouble k)) -> (forall k, natp k -> p k -> p (csucc k) -> p (csucc (cdouble k))) -> forall n, natp n -> p n. Proof. move => p0 p1 pe po. apply: Nat_induction6; first by apply: p0. move => n nN Hrec; move:(NS_half (csucc n)) => hN. case:(even_odd_dichot nN). + by move => ->. + by move => [sa sb]; rewrite sa; apply: (pe _ hN); apply: (Hrec _ sb). + by move => [sa sb sc]; rewrite sa; apply: (po _ hN); apply: Hrec. Qed. Lemma split_sum_even_odd (F: fterm) n: natp n -> n <> \0c -> csumb (Nintc n) F = csumb (Nintc (chalf n)) (fun k => F (cdouble k)) +c csumb (Nintc (chalf (cpred n))) (fun k => F (csucc (cdouble k))). Proof. move => nN nz. set A := Zo (Nintc n) evenp. set B := Zo (Nintc n) oddp. have pa: disjoint A B by apply:disjoint_pr => u /Zo_hi eu /Zo_hi [_]. have -> : Nintc n = A \cup B. set_extens t; last by move/setU2_P; case => /Zo_S. case:(p_or_not_p (evenp t)) => et ta; first by apply: setU2_1; apply:Zo_i. apply: setU2_2; apply:Zo_i => //; split => //; apply: (Nint_S ta). move:(NS_half n) => hN. move: (cpred_pr nN nz) => [pN pv]. move:(NS_half (cpred n)) => hpN. rewrite (csumA_setU2 _ pa); apply: f_equal2;apply:csum_Cn2; split. + move => x /(NintcP hN) xle; move:(NS_le_nat xle hN) => xN. apply/Zo_P; split; last by apply:even_double. by apply/(NintcP nN); apply:half_monotone2. + by move => x y /Nint_S xN /Nint_S yN; move/(double_inj xN yN). + move => y /Zo_P[yi ye]; move:(half_even ye) => he; exists (chalf y) => //. by apply /(NintcP hN); move/(NintcP nN): yi => /(half_monotone (proj1 ye) nN). + move => x /(NintcP hpN) xle; move:(NS_le_nat xle hpN) => xN. apply/Zo_P; split; last by apply:odd_succ_double. apply/(NintcP nN); rewrite pv. by apply/(cleSSP (CS_nat (NS_double xN)) (CS_nat pN));apply: half_monotone2. + move => x y /Nint_S xN /Nint_S yN. have ha: (cardinalp (cdouble x)) by rewrite /cdouble; fprops. have hb: (cardinalp (cdouble y)) by rewrite /cdouble; fprops. by move/ (succ_injective1 ha hb) /(double_inj xN yN). + move => y /Zo_P[yi yo]; move:(half_odd yo) => he; exists (chalf y) => //. apply /(NintcP hpN); move/(NintcP nN): yi. have ha: (cardinalp (cdouble(chalf y))) by rewrite /cdouble; fprops. have hb: cardinalp (cdouble (chalf (cpred n))) by rewrite /cdouble; fprops. have hc: cardinalp (csucc (cdouble (chalf (cpred n)))) by apply: CS_succ. rewrite {1} pv {1} he;case: (cdouble_halfV pN) => eq; rewrite {1} eq. move/(cleSSP ha hb) => h. by apply/(double_monotone (NS_half y) hpN). have hf:natp (csucc (cdouble (chalf (cpred n)))) by rewrite -eq. move/(cleSSP ha hc); move/(cltSleP hf); rewrite - (double_succ hpN). by move/(double_monotone2 (NS_half y) (NS_succ hpN))/(cltSleP hpN). Qed. Lemma split_sum_even_odd_alt (F: fterm) n: natp n -> csumb (Nint n) F = csumb (Nint (chalf (csucc n))) (fun k => F (cdouble k)) +c csumb (Nint (chalf n)) (fun k => F (csucc (cdouble k))). Proof. move => nN. case: (equal_or_not n \0c) => nz. rewrite nz succ_zero half0 half1 Nint_co00. rewrite /csumb !csum_trivial; bw; aw; fprops. case: (equal_or_not n \1c) => no. rewrite no succ_one half1 half2 Nint_co00 /csumb (proj2 Nint_co01). set F1 := Lg _ _; set F2 := Lg _ _. have ha: (domain F1 = singleton \0c) by rewrite /F1; bw. have hb: (domain F2 = singleton \0c) by rewrite /F2; bw. have hc:= (set1_1 \0c). rewrite (csum_trivial1 ha) (csum_trivial1 hb) /F1 /F2; bw. rewrite cdouble0 csum_trivial; bw; aw; fprops. move: (cpred_pr nN nz) => [sa sb]. have h: (cpred n) <> \0c by move => h; case no; rewrite sb h succ_zero. move:(cpred_pr sa h) => [sa' sb']. move:(split_sum_even_odd F sa h). rewrite (Nint_co_cc sa)(Nint_co_cc ((NS_half _))). rewrite (Nint_co_cc (NS_half _)) -(half_succ sa) -(half_succ sa'). by rewrite - sb' - sb. Qed. (** base two log *) Definition clog2 n := least_ordinal (fun z => n \0c [_ _ hc]; move: (hc _ OS0 h) => /sub_set0 ->. Qed. Lemma clog_nz n (m := clog2 n): natp n -> n <> \0c -> [/\ natp m, m <> \0c, \2c ^c (cpred m) <=c n & n nN nz; move: (CS_nat nN) => cn. rewrite /m /clog2; set p := (fun z => n [sa sb sc]. move:(sc _ (OS_cardinal cn) pn) => le1. have mN: natp m. case: (equal_or_not m n) => eq1; first by ue. move/oltP0: (conj le1 eq1)=> [ _ _ /OFS_in_fin h]. by apply/NatP/h /NatP. case: (equal_or_not m \0c) => mz. by case:nz; move: sb; rewrite /p mz cpowx0 => /clt1. move: (cpred_pr mN mz) => [ha hb]. split => //; case: (NleT_el (NS_pow NS2 ha) nN) => // lt2. move: (cpred_lt mN mz) => /oclt lt3. case:(oltNge lt3 (sc _ (proj31_1 lt3) lt2)). Qed. Lemma clog_pr n m: natp n -> natp m -> \2c ^c m <=c n -> n clog2 n = csucc m. Proof. move => nN mN eq1 eq2. case: (equal_or_not n \0c) => nz. by move: eq1; rewrite nz => /cle0 =>/ (cpow_nz card2_nz). move:(clog_nz nN nz) => [lN lz eq3 eq4]. move:(cle_ltT eq1 eq4) => /(cpow2_MeqltP mN lN) /(cleSltP mN); apply:cleA. move:(cpred_pr lN lz) => [sc sd]. move:(cle_ltT eq3 eq2) => /(cpow2_MeqltP sc (NS_succ mN)) /(cleSltP sc); ue. Qed. Lemma clog_double n: natp n -> n <> \0c -> clog2 (cdouble n) = csucc (clog2 n). Proof. move => nN nz. move:(clog_nz nN nz) => [sa sb sc sd]; apply:(clog_pr (NS_double nN) sa). move: (cpred_pr sa sb) => [ha ->]; rewrite - (cdouble_pow2 ha). by apply/(double_monotone (NS_pow NS2 ha) nN). by rewrite - (cdouble_pow2 sa); apply /(double_monotone2 nN (NS_pow NS2 sa)). Qed. Lemma clog_succ_double n: natp n -> clog2 (csucc (cdouble n)) = csucc (clog2 n). Proof. move => nN. case: (equal_or_not n \0c) => nz. rewrite nz /cdouble clog0 cprod0r {1} succ_zero; apply:(clog_pr NS1 NS0). rewrite cpowx0; fprops. rewrite succ_zero;apply: (cantor CS1). move:(clog_nz nN nz) => [sa sb sc sd]. apply:(clog_pr (NS_succ (NS_double nN)) sa). move: (cpred_pr sa sb) => [ha ->]; rewrite - (cdouble_pow2 ha). apply: cleT (cleS (NS_double nN)). by apply/(double_monotone (NS_pow NS2 ha) nN). by rewrite - (cdouble_pow2 sa); apply /(double_monotone3 nN (NS_pow NS2 sa)). Qed. Lemma clog1 : clog2 \1c = \1c. Proof. rewrite - {2} succ_zero;apply: (clog_pr NS1 NS0). rewrite cpowx0; fprops. rewrite succ_zero (cpowx1 CS2); apply: clt_12. Qed. Lemma NS_log n: natp n -> natp (clog2 n). Proof. move => nN; case: (equal_or_not n \0c) => nz; first by rewrite nz clog0; fprops. by move:(clog_nz nN nz) => []. Qed. Lemma power2_log_even n: natp n -> n <> \0c -> evenp (\2c ^c (clog2 n)). Proof. move => nN nz; move:(clog_nz nN nz) => [sa sb sc sd]. move:(cpred_pr sa sb) => [ha hb]; rewrite hb - (cdouble_pow2 ha). by apply: (even_double (NS_pow NS2 ha)). Qed. Lemma log2_pow n: natp n -> clog2 (\2c ^c n) = (csucc n). Proof. move => nN; move: (NS_pow NS2 nN) => pN. apply:(clog_pr pN nN (proj33 (NleR pN))). apply/(cpow2_MeqltP nN (NS_succ nN)); apply/(cltS nN). Qed. Definition base_two_reverse n := let F := the_expansion \2c n in let p := cardinal (domain F) in expansion_value (Lg p (fun z => (Vg F (p -c (csucc z))))) \2c. Lemma base2r_zero: base_two_reverse \0c = \0c. Proof. rewrite / base_two_reverse (the_expansion_zero NS2 clt_12). rewrite domain_set0 cardinal_set0; apply: csum_trivial; bw. Qed. Lemma base2r_one: base_two_reverse \1c = \1c. Proof. rewrite / base_two_reverse (the_expansion_digit NS2 clt_12 card1_nz clt_12). move: (simple_fct2 \0c \1c) => [_ sb _ _ h]. rewrite sb cardinal_set1 /expansion_value Lg_domain csum_trivial3 h cpowx0. have zz: inc \0c (singleton \0c) by fprops. by bw; [rewrite (cprod1r CS1) (card_card CS1) | rewrite succ_zero cdiff_nn ]. Qed. Lemma base2_expansion_prop n (F:= the_expansion \2c n) (p := cardinal (domain F)) : natp n -> n <> \0c -> [/\ expansion_of F \2c p n, p <> \0c & Vg F (cpred p) = \1c]. Proof. move => nN nz. move: (the_expansion_pr NS2 clt_12 nN); rewrite -/F -/p; move => [ha hb]. case: (equal_or_not p \0c) => pz. case: nz. move: ha => [hc <-]; apply: csum_trivial; bw. by apply:card_nonempty. split => //; case: hb => // [] [_ hb]. move:ha => [[_ pN _ [pb pc pd]] pe]. suff: inc (cpred p) (domain F) by move => /pd/clt2[]. rewrite pc; apply /(NltP pN); apply: (cpred_lt pN pz). Qed. Lemma log2_pr1 n (k := \2c ^c (cpred (clog2 n))) : natp n -> n <> \0c -> n = k +c (n %%c k). Proof. move => nN nz. move:(clog_nz nN nz) => [sa sb]; rewrite /k. move: (cpred_pr sa sb) => []; set m := cpred (clog2 n). move => mN mv sc sd. move: (cdivision nN (NS_pow NS2 mN) (@cpow2_nz m)) => [qN rN Ha]. move/(cdivision_prop_alt nN (NS_pow NS2 mN) qN rN (@cpow2_nz m)):(Ha). move: Ha => [nv rs] [hu hv _]. case: (equal_or_not (n %/c \2c ^c m) \0c) => qnz. by move: (cle_ltT sc hv); rewrite qnz succ_zero (cprod1r (proj31 sc)); case. move:(cle_ltT hu sd); rewrite mv - (cdouble_pow2 mN) cprodC. move/(cprod_lt2r (NS_pow NS2 mN) qN NS2) /clt2; case => // eq1. move: nv; rewrite eq1 cprod1r//; fprops. Qed. Lemma log2_pr2 n : natp n -> clog2 n = cardinal (domain (the_expansion \2c n)). Proof. move => nN. case: (equal_or_not n \0c) => nz. by rewrite nz (the_expansion_zero NS2 clt_12) clog0 domain_set0 cardinal_set0. move:(base2_expansion_prop nN nz). set c := cardinal _; move => [[sa sb] cz sd]. move: (sa) => [_ cN _ _]. move: (cpred_pr cN cz) => [se sf]. move: (expansion_prop9 sa); rewrite sb sf;apply: (clog_pr nN se). rewrite sf in sa. have ca: cardinalp (\2c ^c cpred c) by fprops. rewrite - sb (expansion_prop7 sa (CS_nat se)) sd (cprod1l ca) csumC. by apply: csum_M0le. Qed. Lemma base2r_even n: natp n -> base_two_reverse (cdouble n) = base_two_reverse n. Proof. move => nN. have dN:= (NS_double nN). case: (equal_or_not n \0c) => nz; first by rewrite nz cdouble0. move:(base2_expansion_prop nN nz). move:(base2_expansion_prop dN (cprod2_nz card2_nz nz)). rewrite /base_two_reverse. set E1 := (the_expansion \2c n). set E2 := (the_expansion \2c (cdouble n)). set p1:= (cardinal (domain E1)); set p2 := (cardinal (domain E2)). move => [[sa sb] hb hc] [[sc sd] hf hg]. move: (expansion_prop8_rev sc NS0 clt_02)=> []. set E3 := Lg _ _. rewrite sd (csum0r (CS_prod2 _ _)) cprodC -/(cdouble n) => qa qb. have qc: (expansion_normal_of E2 \2c p2 (cdouble n)). split => //; right; split => //; rewrite hc; fprops. have p1N: natp p1 by case: sc. have qd: (expansion_normal_of E3 \2c (csucc p1) (cdouble n)). split => //; right; split => //; first by apply:succ_nz. have p1i: inc p1 (csucc p1) by apply: Nsucc_i. rewrite (cpred_pr2 p1N) /E3; bw; Ytac0; rewrite hg; fprops. move:(expansion_unique1 qc qd)=> [qe qf]. have zi: inc \0c (csucc p1) by apply/(NleP p1N); fprops. have p1i: inc p1 (csucc p1) by apply/(NleP p1N); fprops. have qg: Vg E2 \0c = \0c by rewrite qe /E3; bw; Ytac0. have cp1:= CS_nat p1N. have ns1: natp (csucc p1) by apply: NS_succ. have hh: expansion (Lg (csucc p1) (fun z => Vg E2 (csucc p1 -c csucc z))) \2c (csucc p1). move: sa => [q1 q2 q3 [q4 q5 q6]]; split => //; split; bw; fprops. move => i ii; bw; apply: q6; rewrite q5 qf (cdiff_pr6 p1N). apply/(NleP p1N);apply: (cdiff_le1 _ cp1). exact:(NS_inc_nat ns1 ii). rewrite qf (expansion_prop7 hh cp1) (LVg_E _ p1i) cdiff_nn qg cprod0l. rewrite csum0r; last by rewrite /expansion_value /csumb; fprops. rewrite /expansion_value /restr !Lg_domain;apply:csumb_exten. move => i ii /=. have iN:= NS_inc_nat p1N ii. move/(NltP p1N): (ii) => lip. have sip1: csucc i <=c p1 by apply/(cleSltP iN). have ha: inc (p1 -c i) (csucc p1). apply/(NleP p1N);apply: (cdiff_le1 _ cp1). have isp: inc i (csucc p1) by rewrite (succ_of_Nat p1N); apply:setU1_r. bw; rewrite (cdiff_pr6 p1N iN) qe - (cdiff_A1 p1N iN sip1) /E3; bw. by rewrite (Y_false (cdiff_nz lip)). Qed. Lemma base2r_odd n: natp n -> base_two_reverse (csucc (cdouble n)) = \2c ^c (clog2 n) +c base_two_reverse n. Proof. move => nN. have dN:= (NS_double nN). case: (equal_or_not n \0c) => nz. rewrite nz cdouble0 succ_zero base2r_one base2r_zero clog0. by rewrite cpowx0 (csum0r CS1). move:(base2_expansion_prop nN nz). move:(base2_expansion_prop (NS_succ dN) (@succ_nz _)). rewrite /base_two_reverse. set E1 := (the_expansion \2c n). set E2 := (the_expansion \2c (csucc (cdouble n))). set p1:= (cardinal (domain E1)); set p2 := (cardinal (domain E2)). move => [[sa sb] hb hc] [[sc sd] hf hg]. move: (expansion_prop8_rev sc NS1 clt_12)=> []. set E3 := Lg _ _. rewrite sd cprodC -/(cdouble n) - (Nsucc_rw dN) => qa qb. have qc: (expansion_normal_of E2 \2c p2 (csucc (cdouble n))). split => //; right; split => //; rewrite hc; fprops. have p1N: natp p1 by case: sc. have qd: (expansion_normal_of E3 \2c (csucc p1) (csucc (cdouble n))). split => //; right; split => //; first by apply:succ_nz. have p1i: inc p1 (csucc p1) by apply: Nsucc_i. rewrite (cpred_pr2 p1N) /E3; bw; Ytac0; rewrite hg; fprops. have [qe qf]:=(expansion_unique1 qc qd). have zi: inc \0c (csucc p1) by apply/(NleP p1N); fprops. have p1i: inc p1 (csucc p1) by apply/(NleP p1N); fprops. have qg: Vg E2 \0c = \1c by rewrite qe /E3; bw; Ytac0. have cp1:= CS_nat p1N. have ns1:=(NS_succ p1N). have hh: expansion (Lg (csucc p1) (fun z => Vg E2 (csucc p1 -c csucc z))) \2c (csucc p1). move: sa => [q1 q2 q3 [q4 q5 q6]]; split => //; split; bw; fprops. move => i ii; bw; apply: q6; rewrite q5. rewrite qf (cdiff_pr6 p1N (NS_inc_nat ns1 ii)). apply/(NleP p1N);apply: (cdiff_le1 _ cp1). rewrite qf (expansion_prop7 hh cp1) (LVg_E _ p1i) cdiff_nn qg csumC. rewrite (cprod1l (CS_pow _ _)) (log2_pr2 nN); apply:f_equal. rewrite /expansion_value /csumb; apply: f_equal; bw. apply:Lg_exten => // i ii. have iN:= NS_inc_nat p1N ii. move/(NltP p1N): (ii) => lip. have sip1: csucc i <=c p1 by apply/(cleSltP iN). have ha: inc (p1 -c i) (csucc p1). apply/(NleP p1N);apply: (cdiff_le1 _ cp1). have isp: inc i (csucc p1) by rewrite (succ_of_Nat p1N); apply:setU1_r. bw; rewrite (cdiff_pr6 p1N iN) qe - (cdiff_A1 p1N iN sip1) /E3; bw. by rewrite (Y_false (cdiff_nz lip)). Qed. Lemma NS_reverse n: natp n -> natp (base_two_reverse n). Proof. move: n; apply: fusc_induction. + rewrite base2r_zero; fprops. + rewrite base2r_one; fprops. + by move => k kn; rewrite base2r_even. + move => k kn sa _; rewrite ( base2r_odd kn); apply:NS_sum sa. apply:(NS_pow NS2 (NS_log kn)). Qed. Lemma base2r_oddp n: natp n -> n <> \0c -> oddp (base_two_reverse n). Proof. move: n; apply: fusc_induction. + by case. + rewrite base2r_one => _; apply: odd_one. + move => k kN H ck. by rewrite (base2r_even kN); apply: H => h; case:ck; rewrite h cdouble0. + move =>k kN Ha _ ck. rewrite (base2r_odd kN). case: (equal_or_not k \0c) => knz. rewrite knz clog0 base2r_zero cpowx0 (csum0r CS1); apply: odd_one. apply: (csum_of_even_odd (power2_log_even kN knz) (Ha knz)). Qed. Lemma base2r_oddK n (r := base_two_reverse) : oddp n -> r (r n) = n. Proof. move => [nN nen]; move:(NS_half n) => hN; case: (cdouble_halfV nN) => eq. case: nen; rewrite eq; apply: (even_double hN). have nz: n <> \0c by rewrite eq; apply: succ_nz. have ox:=(base2r_oddp nN nz). move: (erefl (r n)); pose x := r n; rewrite - {1 3} /x /r. have xn: natp x by apply: NS_reverse. case: (equal_or_not x \0c) => xz. by case: (proj2 ox); rewrite -/r - /x xz; apply: even_zero. rewrite /base_two_reverse. move:(base2_expansion_prop nN nz) (base2_expansion_prop xn xz). set Fn := (the_expansion \2c n); set Fx := (the_expansion \2c x). set pn := cardinal (domain Fn); set px := (cardinal (domain Fx)). set Gn := Lg _ _; set Gx := Lg _ _. move => [[pa pb] pc pd] [[qa qb] qc qd] eq1. move:(pa) => [ha hb hc [hd he hf]]. have hi: expansion Gn \2c pn. split => //; rewrite /Gn; split; bw; fprops => i iI; bw. move/(NltP hb): iI => ra; move:(NS_lt_nat ra hb) => iN. have rb: csucc i <=c pn by apply /cleSltP. apply: hf; rewrite he;apply /(NltP hb). apply:(cdiff_Mlt hb hb rb); apply:(csum_M0lt hb (@succ_nz _)). have Ha:(expansion_normal_of Fx \2c px x). split => //; right; split => //; rewrite qd; fprops. have Hb:(expansion_normal_of Gn \2c pn x). have pp:inc (cpred pn) pn by apply /(NltP hb); apply: cpred_lt. have pq: expansion_of Gn \2c pn x by split; [ | symmetry]. split => //;right; split => //;rewrite /Gn; bw. rewrite - (proj2 (cpred_pr hb pc)) cdiff_nn => bad. have [sa sb]:=(cpred_pr hb pc). move: pb; rewrite /expansion_value he sb. set t := csumb _ _ => eq2. suff: evenp t by move => eq3; case: nen; rewrite - eq2. have : forall i, i<=c (cpred pn) -> natp (Vg Fn i). move => i /(cltSleP sa); rewrite - sb => /(NltP hb). rewrite - he; move=> /hf => h; apply: (NS_lt_nat h NS2). rewrite /t; move: (cpred pn) sa; apply: Nat_induction. rewrite succ_zero csum_trivial3 bad (cprod0l). rewrite (card_card CS0); move => _; apply: even_zero. move => jk kN Hrec aux; rewrite (induction_on_sum _ (NS_succ kN)). have hw:(forall i, i <=c jk -> natp (Vg Fn i)). by move => i ij; apply: aux; apply: (cleT ij (cleS kN)). apply: (csum_of_even (Hrec hw)); rewrite - (cdouble_pow2 kN) double_prod. apply: even_double; apply: NS_prod; [ apply: aux; fprops | fprops ]. have [eq2 eq3] := (expansion_unique1 Ha Hb). rewrite - pb /expansion_value /Gx Lg_domain eq3 he eq2 /Gn. apply: csumb_exten => i iI. move/(NltP hb):(iI) => ra;have ra1:= (proj1 ra). have iN:=(NS_lt_nat ra hb). have rb: csucc i <=c pn by apply /cleSltP. have rc: pn -c csucc i r (r (r n)) = r n. Proof. move => nN. case: (equal_or_not n \0c) => nz; first by rewrite nz /r !base2r_zero. by apply:base2r_oddK; apply: base2r_oddp. Qed. Lemma div3_props: [/\ \0c %%c \3c = \0c, \1c %%c \3c = \1c& \2c %%c \3c = \2c]. Proof. have ha := NS3. have hb:= (cltS NS2). have hc:= (clt_ltT clt_12 hb). have hd:= (clt_ltT clt_01 hc). by split; symmetry;apply:crem_small. Qed. Lemma div3_props2: \3c %%c \3c = \0c /\ \4c %%c \3c = \1c. Proof. move: (cdivides_itself NS3) div3_props => [_ _ ha] [_ hb _]. split => //. move: (crem_sum NS3 card3_nz NS3 NS1). by rewrite /eqmod ha hb (csum0l CS1) hb -(Nsucc_rw NS3). Qed. Lemma div3_vals n (m := n %%c \3c): natp n -> [\/ m = \0c, m = \1c | m = \2c]. Proof. move => nN. move: (cdivision nN NS3 card3_nz) => []; rewrite -/m => _ mN [_ m3]. case: (equal_or_not m \2c) => m2; first by constructor 3. move /(cltSleP NS2): m3 => l2; case: (clt2 (conj l2 m2)) => h; in_TP4. Qed. Lemma double_mod3 n: natp n -> (n %%c \3c = \0c <-> (cdouble n) %%c \3c = \0c). Proof. have [sa sb sc]:=div3_props. move => nN. move: (crem_prod NS3 card3_nz NS2 nN); rewrite sc => H. split => hb; first by move: H; rewrite /eqmod hb cprod0r sa. move: H; rewrite /eqmod -/(cdouble n) hb; case: (div3_vals nN) => // ->. by rewrite (cprod1r CS2) sc => h; case: card2_nz. by rewrite two_times_two (proj2 div3_props2) => h ; case: card1_nz. Qed. Lemma cmodmod n p: natp n -> natp p -> p <> \0c -> (n %%c p) %%c p = n %%c p. Proof. move => nN pN pnz; move: (cdivision nN pN pnz) => [qN rN [pa pb]]. have dp: (cdivision_prop (n %%c p) p \0c (n %%c p)). by split => //; rewrite cprod0r (Nsum0l rN). by rewrite - (proj2 (cquorem_pr rN pN NS0 rN dp)). Qed. Lemma cmodmod3 n: natp n -> (n %%c \3c) %%c \3c = n %%c \3c. Proof. move => nN; apply:(cmodmod nN NS3 card3_nz). Qed. Lemma cmodmod2 n: natp n -> (n %%c \2c) %%c \2c = n %%c \2c. Proof. move => nN; apply:(cmodmod nN NS2 card2_nz). Qed. Lemma csum_nz a b: a +c b = \0c -> (a = \0c /\ b = \0c). Proof. move => h. case: (emptyset_dichot a) => az. move: h; rewrite az - csum2cr (csum0l (CS_cardinal b)). by move /card_nonempty. move: (az) => [t ta]. move: (csucc_pr1 a t); rewrite (setC1_K ta) => ca. move: h; rewrite - csum2cl ca csumC. by rewrite (csum_via_succ _ (CS_cardinal _)) => /succ_nz. Qed. (* Fibonacci *) Definition Fib2_rec := induction_term (fun _ v => (J (Q v) (P v +c Q v))) (J \0c \1c). Definition Fib n := P (Fib2_rec n). Lemma Fib_rec n : natp n -> Fib (csucc (csucc n)) = Fib n +c Fib (csucc n). Proof. move => nN; rewrite /Fib/Fib2_rec (induction_terms _ _ (NS_succ nN)). rewrite pr1_pair (induction_terms _ _ nN); aw. Qed. Lemma Fib0: Fib \0c = \0c. Proof. rewrite /Fib /Fib2_rec induction_term0; aw. Qed. Lemma Fib1: Fib \1c = \1c. Proof. rewrite /Fib/Fib2_rec - succ_zero (induction_terms _ _ NS0) induction_term0; aw. Qed. Lemma Fib2: Fib \2c = \1c. Proof. rewrite - succ_one - succ_zero (Fib_rec NS0) succ_zero. by rewrite Fib0 Fib1 (csum0l CS1). Qed. Lemma Fib3: Fib \3c = \2c. Proof. rewrite /card_three - succ_one (Fib_rec NS1) succ_one. by rewrite Fib1 Fib2 card_two_pr. Qed. Lemma NS_Fib n: natp n -> natp (Fib n). Proof. move => nN; suff: natp (Fib n) /\ natp (Fib (csucc n)) by case. move: n nN; apply: Nat_induction. rewrite succ_zero Fib0 Fib1; fprops. move => n nN [sa sb]; split => //; rewrite (Fib_rec nN); fprops. Qed. Hint Resolve NS_Fib : fprops. Lemma Fib_gt0 n: natp n -> n <> \0c -> (Fib n) <> \0c. Proof. move => nN nz; move:(cpred_pr nN nz) => [sa ->]. move: (cpred n) sa; clear n nN nz; apply: Nat_induction. rewrite succ_zero Fib1; fprops. by move => n nN Hr; rewrite (Fib_rec nN); move/csum_nz => [_]. Qed. Lemma Fib_smonotone n m: natp n -> natp m -> n <> \0c -> n <> \1c -> n Fib n nN mN nz no. case: (equal_or_not m \0c) => mz; first by rewrite mz; move/clt0. move:(cpred_pr mN mz) => [sa ->]; move/(cltSleP sa). move: (cpred m) sa; clear m mN mz; apply:Nat_induction. move => /cle0 ->;rewrite succ_zero Fib0 Fib1; apply: clt_01. move => m mN Hrec; rewrite (Fib_rec mN) csumC. case: (equal_or_not n (csucc m)) => eq1 h. rewrite - eq1; apply: (csum_M0lt (NS_Fib nN)); apply:(Fib_gt0 mN) => mz. by case: no; rewrite eq1 mz succ_zero. move: (csum_M0le (Fib m) (CS_nat (NS_Fib (NS_succ mN)))). by apply:clt_leT; apply: Hrec; apply /(cltSleP mN). Qed. Lemma Fib_monotone n m: natp n -> natp m -> n <=c m -> Fib n <=c Fib m. Proof. move => nN mN le; move:(CS_nat (NS_Fib mN)) => h. case:(equal_or_not n m) => eq; first by rewrite eq; apply: (cleR h). case:(equal_or_not n \0c) => eq2; first by rewrite eq2 Fib0; apply:czero_least. case:(equal_or_not n \1c) => eq3. move: le; rewrite eq3 Fib1 => hh; apply:(cge1 h); apply:(Fib_gt0 mN) => mz. apply: (cleNgt hh); rewrite mz; exact: (clt_01). exact (proj1(Fib_smonotone nN mN eq2 eq3 (conj le eq))). Qed. Lemma Fib_gt1 n: natp n -> \2c \1c nN h. by move:(Fib_smonotone NS2 nN card2_nz (nesym card_12) h); rewrite Fib2. Qed. Lemma Fib_eq1 n: natp n -> (Fib n = \1c <-> (n = \1c \/ n = \2c)). Proof. move => nN; split; last by case => ->; rewrite ?Fib1 ?Fib2. move => eq1. case: (NleT_ell nN NS2); first by right. case /clt2; [move => ne0; move: eq1; rewrite ne0 Fib0; fprops| by left]. by move/(Fib_gt1 nN); rewrite eq1; case. Qed. Lemma Fib_eq n m: natp n -> natp m -> (Fib n = Fib m <-> [\/ n = m, (n = \1c /\ m = \2c) |(n = \2c /\ m = \1c) ]). Proof. move => nN mN; split; last first. by case; first (by move ->); move => [-> ->]; rewrite Fib1 Fib2. wlog : n m nN mN / n <=c m => H. case: (NleT_ee nN mN); [by apply:H | move => le eq]. case: (H _ _ mN nN le (sym_eq eq)). + by constructor 1. + by move => [sa sb]; constructor 3. + by move => [sa sb]; constructor 2. case: (equal_or_not n m) => enm eq; first by constructor 1. case: (equal_or_not n \0c) => nz. by rewrite nz in enm; move:(Fib_gt0 mN (nesym enm));rewrite - eq nz Fib0;case. case: (equal_or_not n \1c) => n1. case: (equal_or_not \2c m) => m2; first by constructor 2. have: \2c //; rewrite - succ_one; apply/(cleSltP NS1); rewrite - n1. by move/(Fib_gt1 mN); rewrite - eq n1 Fib1; case. by case: (proj2(Fib_smonotone nN mN nz n1 (conj H enm))). Qed. Lemma Fib_add n m: natp n -> natp m -> Fib (csucc (n +c m)) = (Fib n) *c (Fib m) +c (Fib (csucc n)) *c (Fib (csucc m)). Proof. move => nn;move: n nn m; apply: Nat_induction. move => m mN; move:(CS_nat (NS_Fib (NS_succ mN))) => cf. rewrite (Nsum0l mN) succ_zero Fib0 Fib1 cprod0l (cprod1l cf); aw. move => n nN Hrec m mN. case: (equal_or_not m \0c) => mz. move:(CS_nat (NS_Fib (NS_succ (NS_succ nN)))) => cf. rewrite mz succ_zero Fib0 Fib1 cprod0r (cprod1r cf) (csum0l cf); aw;fprops. move:(cpred_pr mN mz) => [sa sb]. rewrite (csum_Sn _ nN) (Fib_rec (NS_sum nN mN)) (Fib_rec nN) (Hrec _ mN). rewrite cprodDr csumA csumA {1} sb (csum_nS _ sa) (Hrec _ sa) - sb. apply:f_equal2; last by reflexivity. rewrite csumC csumA (csumC (_ *c _)). by rewrite - cprodDl {2} sb - (Fib_rec sa) - sb csumC. Qed. Lemma Fib_sub n m: natp n -> natp m -> m <=c n-> Fib (n -c m) = Yo (evenp m) (Fib n *c Fib (csucc m) -c Fib (csucc n) *c Fib m) (Fib (csucc n) *c Fib m -c Fib n *c Fib (csucc m)). Proof. move: even_zero => ez. move => nN; move: n nN m; apply: Nat_induction. move=> m mN /cle0 ->; rewrite (Y_true ez) Fib0 cprod0r cprod0l. by rewrite cdiff_nn Fib0. move => n nN Hrec m mN; case: (equal_or_not m \0c) => mz. move:(NS_succ nN) => ha; move:(NS_Fib ha) => hb. rewrite mz (Y_true ez) succ_zero Fib0 Fib1 cprod0r. by rewrite (cdiff_n0 ha) (cprod1r (CS_nat hb)) (cdiff_n0 hb). move:(cpred_pr mN mz); set c := cpred m; move => [cN cv]. rewrite cv (cdiff_pr6 nN cN); move /(cleSSP (CS_nat cN) (CS_nat nN)) => h. move: (NS_Fib cN)(NS_Fib nN)(NS_Fib (NS_succ cN))(NS_Fib (NS_succ nN)). move => qa qb qc qd. rewrite (Hrec _ cN h) (Fib_rec cN) (Fib_rec nN) cprodDl cprodDr. Ytac ec; first rewrite (Y_false (proj2 (succ_of_even ec))) cdiff_pr5; fprops. rewrite (Y_true (succ_of_odd (conj cN ec))) cdiff_pr5; fprops. Qed. Lemma Fib_odd n (square := fun a => a *c a): natp n -> Fib (csucc (cdouble n)) = square (Fib n) +c square (Fib (csucc n)). Proof. by move => nN; rewrite /cdouble two_times_n (Fib_add nN nN). Qed. Lemma Fib_even n: natp n -> Fib (cdouble (csucc n)) = Fib (csucc n) *c (cdouble (Fib n) +c Fib (csucc n)). Proof. move => nN. rewrite (double_succ nN) /cdouble two_times_n - (csum_nS _ nN). rewrite (Fib_add nN (NS_succ nN)) cprodC - cprodDl (Fib_rec nN). by rewrite csumA two_times_n. Qed. Lemma Fib_add3 n: natp n -> Fib (n +c \3c) = Fib n +c cdouble (Fib (csucc n)). Proof. move => nN. rewrite (csum_nS _ NS2) (Fib_add nN NS2) Fib3 Fib2. by rewrite (Nprod1r (NS_Fib nN)) cprodC. Qed. Lemma Fib_div n m: n %|c m -> Fib n %|c Fib m. Proof. move => h;rewrite(cdivides_pr h). move:h => [mN nN _]; move:(NS_quo m n); set k := (m %/c n). case: (equal_or_not n \0c) => nz. rewrite nz cprod0l Fib0 => _; apply: (cdivides_zero NS0). move:(cpred_pr nN nz) => [sN sv]. move:(k); apply: {m mN k} Nat_induction. rewrite cprod0r Fib0; exact (cdivides_zero (NS_Fib nN)). move => m mN Hrec. have ha:= (cdivides_trans2 (NS_Fib sN) Hrec). have hb: Fib n %|c (Fib (csucc (n *c m)) *c Fib n). rewrite cprodC;apply:cdivides_pr1; apply:NS_Fib; fprops. rewrite (cprod_nS _ mN) {3}sv (csum_nS _ sN) (Fib_add (NS_prod nN mN) sN) - sv. exact (proj1 (cdivides_and_sum ha hb)). Qed. Lemma Fib_is_even_mod3 n: natp n -> (evenp (Fib n) <-> \3c %|c n). Proof. have H: forall m, natp m -> evenp (Fib (\3c *c m)). move => m mN. by move:(Fib_div (cdivides_pr1 mN NS3)); rewrite Fib3; move => [sa _ sb]. have aux: forall k, natp k -> csucc (csucc k) = k +c \2c. move => k kN. by rewrite - card_two_pr csumA (Nsucc_rw (NS_succ kN)) (Nsucc_rw). suff H1:forall n, natp n -> oddp (Fib (csucc (\3c *c n))) /\ oddp (Fib (csucc (csucc (\3c *c n)))). move => nN;split; last first. move/cdivides_pr => ->; apply: H; apply: NS_quo. move: NS3 => n3 ef. move:(cdivision nN n3 card3_nz) => [sa sb [sc sd]]; split => //. have ha := (NS_prod n3 sa). move: (H1 _ sa); rewrite (aux _ ha) (Nsucc_rw ha); move => [[_ eqa] [_ eqb]]. by case: (div3_vals nN) => //eq1; move: ef; rewrite sc eq1. apply: {n} Nat_induction. rewrite cprod0r succ_zero succ_one Fib2 Fib1;split; apply odd_one. move => n nN [_ Hrec]; move:(NS_succ nN) => sN. have hc: natp (\3c *c n +c \2c) by apply: (NS_sum (NS_prod NS3 nN) NS2). have ha:= NS_prod NS3 sN. suff hb: oddp (Fib (csucc (\3c *c csucc n))). rewrite (Fib_rec ha); split => //; exact:(csum_of_even_odd (H _ sN) hb). rewrite (cprod_nS _ nN) {2} /card_three (csum_nS _ NS2) (Fib_rec hc). rewrite csumC - (csum_nS _ NS2) -/card_three - (cprod_nS _ nN). by rewrite - {1} (aux _ (NS_prod NS3 nN)); apply:(csum_of_even_odd (H _ sN)). Qed. Definition composite n := exists a, [/\ natp a, \1c natp b -> \1c \1c composite (a *c b). Proof. move => aN bN h1 h2. move/(strict_pos_P1 aN): (clt_ltT clt_01 h1) => anz. by exists a;split => //; [apply:cprod_M1lt | apply: cdivides_pr1]. Qed. Lemma composite_prod_rev n: natp n -> composite n -> exists a b, [/\ natp a, natp b, \1c nN [a [aN pa pb pc]]; exists a,(n %/c a). move:(cdivides_pr pc) (NS_quo n a) => eq qN; rewrite - eq; split => //;split. rewrite - succ_zero; apply /(cleSltP NS0); split;fprops => eq2. by case:(proj2 (clt_ltT clt_01 (clt_ltT pa pb))); rewrite eq - eq2 cprod0r. by move => eq1;move: (proj2 pb);rewrite eq - eq1 (cprod1r (CS_nat aN)). Qed. Lemma composite_even_fib n: natp n -> \2c composite (Fib (cdouble n)). Proof. move => nN n2; case: (equal_or_not n \0c) => nz. by case:(proj2 (clt_ltT clt_02 n2)). move:(nN) n2;move: (cpred_pr nN nz) => [sa ->] sN n2. have ha:= NS_Fib sN. have hb:= NS_Fib sa. have hc:= (NS_sum (NS_double hb) ha). have hd := (Fib_gt1 sN n2). rewrite (Fib_even sa); apply:(composite_prod ha hc hd). apply: (clt_leT hd); rewrite csumC; apply:(csum_M0le _(CS_nat ha)). Qed. Lemma composite_fib n: natp n -> n <> \4c -> composite n -> composite (Fib n). Proof. move => nN n4 [a [aN a1 an dvd]]. case: (equal_or_not \2c a) => ea2. move: an n4. move:(cdivides_pr dvd); rewrite - ea2 -/(double _) -/(chalf _) => -> an n4. have kN:= (NS_half n). apply: (composite_even_fib kN); split. case: (NleT_el NS2 kN) => // /clt2; case => eq; move:an; rewrite eq ?cprod0r ? (cprod1r CS2) => hh; first case: (clt0 hh). by case: (proj2 hh). by move => e1; case: n4; rewrite - e1 two_times_two. have a2: \2c //;rewrite - succ_one; apply /(cleSltP NS1). have anz:= (nesym (proj2 (clt_ltT clt_01 a1))). exists (Fib a); split => //. + by apply: NS_Fib. + apply: (Fib_gt1 aN a2). + apply: (Fib_smonotone aN nN anz (nesym (proj2 a1)) an). + exact(Fib_div dvd). Qed. (** ** EIII-5-8 Combinatorial analysis *) Theorem shepherd_principle f c: function f -> (forall x, inc x (target f) -> cardinal (Vfi1 f x) = c) -> cardinal (source f) = (cardinal (target f)) *c c. Proof. move=> ff cc. set (pa := Lg (target f) (fun z=> (Vfi1 f 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 /Vfi1/Vfi; bw=> i j y it jt; bw. move => sa sb. by rewrite (iim_fun_set1_hi ff sa) (iim_fun_set1_hi ff sb). move: (csum_pr pa). have ->:csumb (domain pa) (fun a => cardinal (Vg pa a)) = csum (cst_graph (domain pa) c). by apply: csumb_exten; rewrite /pa; bw => t tf; bw; apply: cc. rewrite csum_of_same -up cprodC cprod2cl {2}/pa; bw => <-. apply /card_eqP /equipotent_disjointU; fprops. rewrite /disjointU_fam; split;fprops; bw. move=> i id; bw; apply: Eq_indexed. Qed. Definition factorial n := cprodb n csucc. Lemma factorial_succ n: natp n -> factorial (csucc n) = (factorial n) *c (csucc n). Proof. move=> nN; exact:(induction_on_prod csucc nN). Qed. Lemma factorial0: factorial \0c = \1c. Proof. by rewrite /factorial cprod_trivial0. Qed. Lemma factorial1: factorial \1c = \1c. Proof. move: NS0 => zb. rewrite - succ_zero factorial_succ // factorial0; aw; apply: CS_succ. Qed. Lemma factorial2: factorial \2c = \2c. Proof. rewrite - succ_one. rewrite (factorial_succ NS1) factorial1 succ_one;aw; fprops. Qed. Lemma factorial_nz n: natp n -> factorial n <> \0c. Proof. move: n;apply: Nat_induction. rewrite factorial0; exact: card1_nz. move=> m mN u; rewrite (factorial_succ mN). apply: cprod2_nz =>//; apply: succ_nz. Qed. Lemma NS_factorial n: natp n -> natp (factorial n). Proof. move: n;apply: Nat_induction; first by rewrite factorial0; fprops. move=> m mN u; rewrite (factorial_succ mN); fprops. Qed. Hint Resolve factorial_nz: fprops. Lemma factorial_prop f: f \0c = \1c -> (forall n, natp n -> f (csucc n) = (f n) *c (csucc n)) -> forall x, natp x -> f x = factorial x. Proof. move=> fz fp; apply: Nat_induction; first by rewrite factorial0. move=> m mN u; rewrite (factorial_succ mN) (fp _ mN) u // . Qed. Lemma factorial_induction n: natp n -> factorial n = induction_term (fun a b => b *c(csucc a)) \1c n. Proof. move: n;apply: Nat_induction. by rewrite factorial0 induction_term0. by move=> m mN h; rewrite (factorial_succ mN) (induction_terms _ _ mN) h. Qed. Lemma quotient_of_factorials a b: natp a -> natp b -> b <=c a -> (factorial b) %|c (factorial a). Proof. move=> aN bN ab; rewrite -(cdiff_rpr ab). move: (NS_diff b aN). set (c := a -c b);rewrite csumC; move: c; apply: Nat_induction. rewrite (Nsum0r bN); apply: cdivides_itself; apply: NS_factorial =>//. move => n nN. rewrite (csum_nS _ nN) (factorial_succ (NS_sum bN nN)). apply: cdivides_trans2; fprops. Qed. Lemma quotient_of_factorials1 a b: natp a -> natp b -> b <=c a -> (factorial (a -c b)) %|c (factorial a). Proof. move=> aN bN leab; apply: (quotient_of_factorials aN); fprops. exact:cdiff_ab_le_a (proj32 leab). Qed. (* Noter *) Lemma divides_smaller a b: b %|c a -> a <> \0c -> b <=c a. Proof. move => ha. rewrite (cdivides_pr ha) => hb. case: (equal_or_not (a %/c b) \0c) => qz. by case: hb; rewrite qz cprod0r. apply: (cprod_M1le (CS_nat (proj32 ha)) qz). Qed. Lemma factorial_monotone a b: natp b -> a <=c b -> factorial a <=c factorial b. Proof. move => bN leab. move:(NS_le_nat leab bN) => aN. apply: (divides_smaller (quotient_of_factorials bN aN leab)). apply: (factorial_nz bN). Qed. Definition number_of_injections b a := (factorial a) %/c (factorial (a -c b)). Lemma number_of_injections_pr a b: natp a -> natp b -> b <=c a -> (number_of_injections b a) *c (factorial (a -c b)) = factorial a. Proof. move=> aN bN leba; rewrite /number_of_injections cprodC. symmetry;apply: cdivides_pr3=>//. by apply: quotient_of_factorials1. Qed. Lemma NS_number_of_injections a b: natp (number_of_injections b a). Proof. apply:NS_quo. Qed. Lemma number_of_injections_base a: natp a -> number_of_injections \0c a = \1c. Proof. move => aN;rewrite /number_of_injections cdiff_n0 //. apply: (cquo_itself (NS_factorial aN) (factorial_nz aN)). Qed. Lemma number_of_injections_rec a b: natp a -> natp b -> b (number_of_injections b a) *c (a -c b) = number_of_injections (csucc b) a. Proof. move=> aN bN ltab. have leab:= proj1 ltab. have sN:= NS_succ bN. have sb:= NS_diff (csucc b) aN. move /(cleSltP bN): ltab => ltab. move: (number_of_injections_pr aN bN leab). rewrite - (number_of_injections_pr aN sN ltab)(csucc_diff aN bN ltab). rewrite (factorial_succ sb) (cprodC (factorial (a -c (csucc b)))) {1} cprodA. apply: (cprod_eq2r (NS_factorial sb)). - exact: (NS_prod (NS_number_of_injections a b) (NS_succ sb)). - exact: (NS_number_of_injections _ _ ). - exact: (factorial_nz sb). 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). red in fsF. have fse: finite_set E by exact: (le_finite_finite fsF lce). have mN: natp m by apply /NatP; rewrite /m; hnf in fsF. move: E fse lce; apply: finite_set_induction0. rewrite cardinal_set0 (number_of_injections_base mN) => _. set f:= empty_function_tg F. suff ->: (injections emptyset F = singleton f) by rewrite cardinal_set1. move: (empty_function_tg_function F) => [pa pb pc]. have injf: injection f by split => //; rewrite /f pb => x y; case; case. have aux: inc f (functions emptyset F) by apply /functionsP. have ff: inc f (injections emptyset F) by apply:Zo_i => //; apply /functionsP. apply: set1_pr => // z /Zo_S vs; exact: (fun_set_small_source vs aux). move=> E a sE naE. rewrite (csucc_pr naE) -/m; set (n := cardinal E) => lem. have snN:= NS_le_nat lem mN. have nN: natp n by exact:(NS_nsucc (CS_cardinal _) snN). have ltnm: n t /Zo_P [] /functionsP [ft st tt] it. have sat: sub E (source t) by rewrite st; fprops. move: (restriction_prop (proj1 it) sat) => pp; move: (pp) => [pa pb pc]. apply: Zo_i; [by apply/functionsP; ue | split => // x y; rewrite pb => xE yE]. by rewrite restriction_V // restriction_V //; apply (proj2 it); apply:sat. have fr: function rf by apply: lf_function. apply: shepherd_principle =>// x. set(K:= Vfi1 rf x). rewrite lf_target; move /Zo_P => [/functionsP [fx sxE txF] injx ]. have fst: finite_set (target x) by hnf;rewrite txF;fprops. move:(cardinal_complement_image injx fst). set (C:= F -s (Imf x)). rewrite sxE txF -/n -/m -/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 /rf lf_source => tG2; aw => xx. move: tG2 => /Zo_P [/functionsP [fz sz tgz] injz ]. have asz: inc a (source z) by rewrite sz; fprops. 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 (restriction_V fz Ez yE) => /(proj2 injz _ _ asz (Ez _ yE)). by move => ya; case: naE; rewrite ya. set (val:= Lf (Vf ^~ a) K C). have fv: function val by 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 [] /functionsP [fu su tu] inju. move: vG2 => /Zo_P [] /functionsP [fvv svv tvv] injv sr1 sr2. apply: function_exten=>//; [ue | ue | rewrite su]. move=> t; case /setU1_P => tE; [ transitivity (Vf x t) | by rewrite tE]. 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 - (setU1_eq yF) - txF /f/extension; aw. 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; apply: (proj2 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 by apply: Zo_i=>//; apply /functionsP. have fi:inc f (Vfi1 rf x). apply /iim_fun_P;exists x;fprops. have <-: (Vf rf f = x) by rewrite /rf lf_V. apply: Vf_pr3=>//; rewrite /rf;aw. by ex_tac; rewrite /f extension_Vf_out. Qed. Lemma permutation_Si E x: inc x (permutations E) -> inc (inverse_fun x) (permutations E). Proof. by move/permutationsP => /inverse_bij_bp /permutationsP. Qed. Lemma permutation_id E: inc (identity E) (permutations E). Proof. move:(identity_prop E) => [_ pa pb]. apply/permutationsP;split => //; apply: identity_fb. Qed. Lemma permutation_Sc E x y: inc x (permutations E) -> inc y (permutations E) -> inc (x \co y) (permutations E). Proof. move=> /permutationsP xp /permutationsP yp; apply /permutationsP. apply: (compose_bp yp xp). Qed. Lemma permutation_coP E x y: inc x (permutations E) -> inc y (permutations E) -> (x \coP y). Proof. move=> /permutationsP [[[fy _] _] sx _] /permutationsP [[[h _] _] _ ty]. by split => //; rewrite ty. Qed. Lemma permutation_A E x y z: inc x (permutations E) -> inc y (permutations E) -> inc z (permutations E) -> x \co (y \co z) = (x \co y) \co z. Proof. move=> ha hb hc;apply: (compfA (permutation_coP ha hb)(permutation_coP hb hc)). Qed. Lemma permutation_lK E x y: inc x (permutations E) -> inc y (permutations E) -> (inverse_fun x) \co (x \co y) = y. Proof. move => ha hb; apply:compf_lK (permutation_coP ha hb). by move/permutationsP:ha => []. Qed. Lemma permutation_lK' E x y: inc x (permutations E) -> inc y (permutations E) -> x \co ( (inverse_fun x) \co y) = y. Proof. move => ha hb. move/permutationsP:(ha) => [[[/ifun_involutive hc _] _] _ _]. rewrite -{1} hc;apply:(permutation_lK (permutation_Si ha) hb). Qed. Lemma permutation_rK E x y: inc x (permutations E) -> inc y (permutations E) -> (x \co y) \co (inverse_fun y) = x. Proof. move => ha hb; apply:compf_rK (permutation_coP ha hb). by move/permutationsP:hb => []. Qed. Lemma permutation_if_inj E f: finite_set E -> function_prop f E E -> injection f -> inc f (permutations E). Proof. move => fse [ff sf tf] ijf; apply/permutationsP; split=> //. by apply: bijective_if_same_finite_c_inj => //; rewrite sf // tf. Qed. Lemma permutations_finite E: finite_set E -> permutations E = injections E E. Proof. move => h; set_extens t => /Zo_P [ha hb]. by move:(proj1 hb) => injf; apply:Zo_i. by apply:(permutation_if_inj h) hb; apply /functionsP. Qed. Lemma number_of_permutations E: finite_set E -> cardinal (permutations E) = (factorial (cardinal E)). Proof. move=> fsE. have cE: natp (cardinal E) by fprops. rewrite ( permutations_finite fsE). rewrite (number_of_injections_prop fsE (cleR (CS_nat cE))). rewrite /number_of_injections cdiff_nn // factorial0 cquo_one //. by apply: NS_factorial. Qed. Definition perm_int n := permutations n. Lemma perm_int_inj n f: natp n -> inc f (perm_int n) -> (forall x y, x y Vf f x = Vf f y -> x = y). Proof. move => nN /permutationsP[ [[_ H] _] sf _]. rewrite sf in H. by move => x y /(NltP nN) xs /(NltP nN) ys sv; apply:H. Qed. Lemma perm_int_surj n f: natp n -> inc f (perm_int n) -> forall y, y exists2 x, x nN /permutationsP[ [_ [_ H]] sf tf]. rewrite sf tf in H. by move => y /(NltP nN) /H [x /(NltP nN) sa sb]; exists x. Qed. Lemma transposition_prop n i j (f:=Lf (fun z => Yo (z = i) j (Yo (z = j) i z)) n n): natp n -> inc i n -> inc j n -> [/\ inc f (perm_int n), Vf f i = j, Vf f j = i, forall k, inc k n -> k <> i -> k <> j -> (Vf f k) = k & forall k, inc k n -> Vf f (Vf f k) = k]. Proof. move => nN iE jE. set F := fun z => Yo (z = i) j (Yo (z = j) i z). have la: lf_axiom F n n. rewrite /F => z; Ytac h1; [ ue | Ytac h2; [ ue | done]]. have pa: Vf f i = j by rewrite /f; aw; Ytac0. have pb: Vf f j = i by rewrite /f; aw; Ytac h1 => //; Ytac0. have pc: forall k, inc k n -> k <> i -> k <> j -> Vf f k = k. by move => k kE ki kj; rewrite /f; aw; Ytac0; Ytac0. have pd:forall k, inc k n -> Vf f (Vf f k) = k. move => k kE; case (equal_or_not k i) => ki; first by rewrite ki pa pb. case (equal_or_not k j) => kj; first by rewrite kj pb pa. by rewrite !(pc _ kE ki kj). have sf: source f = n by rewrite /f;aw. have tf: target f = n by rewrite /f;aw. have ff: function f by apply: (lf_function la). have bf: bijection f. split; split => //; first by rewrite sf => u v /pd {2} <- /pd {2} <- ->. rewrite sf tf => y ye;exists (Vf f y); [ Wtac | by rewrite pd]. split => //; apply /permutationsP; split => //. Qed. Lemma permutation_exists1 n i: natp n -> i exists2 f, inc f (perm_int n) & Vf f \0c = i. Proof. move => nN lin. move /(NltP nN): (cle_ltT (czero_least (proj31_1 lin)) lin) => oE. move /(NltP nN):lin => iI. move:(transposition_prop nN iI oE) => [pa _ pb _ _]. move: pa pb;set f := Lf _ _ _ => pa pb; ex_tac. Qed. Lemma permutation_exists2 E n: natp n -> sub E n -> exists2 f, inc f (perm_int n) & E = Vfs f (cardinal E). Proof. move => nN;move:n nN E; apply: Nat_induction. move => E /sub_set0 ->; rewrite cardinal_set0. by have h := (permutation_id \0c); ex_tac; rewrite fun_image_set0. move => n nN Hrec E seI. case: (equal_or_not E (csucc n)) => Ev. rewrite Ev (card_card (CS_succ _)). set F := (csucc n). have bi:= (identity_fb F). exists (identity F); first apply: permutation_id. have {3} <-: source (identity F) = F by apply: identity_s. by rewrite -/(Imf _) (surjective_pr0 (proj2 bi)) identity_t. move: (setC_ne (conj seI Ev)) => [k1 /setC_P [k1I k1E]]. have sa := (succ_of_Nat nN). have Inm: forall i, inc i n -> inc i (csucc n). by move => i ein; rewrite sa;apply: setU1_r. have Inm': forall i, inc i n -> i <> n. by move => i iin ein; case: (nat_irreflexive nN); rewrite - {1} ein. have nIm:= (Nsucc_i nN). set k0:= Yo (inc n E) k1 n. have kI: inc k0 (csucc n) by rewrite /k0; Ytac h. have kE: ~(inc k0 E) by rewrite /k0; Ytac h. set F := (E +s1 k0) -s1 n. have eq0: F +s1 n = E +s1 k0. rewrite /k0;set_extens t; case/setU1_P. + by move/setC1_P => []. + move => ->; Ytac h; fprops. + move => tE; case (equal_or_not t n) => etn; first by rewrite etn; fprops. apply /setU1_P; left; apply/setC1_P; split ; fprops. + rewrite /F/k0;move => ->;Ytac h; fprops; case (equal_or_not k1 n). by move ->; fprops. move => h'; apply/setU1_P; left; apply/setC1_P; fprops. have fIn: sub F n. move => t /setC1_P [ta tb]. have: inc t (csucc n) by case /setU1_P:ta; [apply: seI | move => ->]. rewrite sa; case /setU1_P => //. move: (Hrec _ fIn) => [f /Zo_P [/functionsP[ff sf tf] fb] fv]. pose g i := Yo (i = n) k0 (Yo (Vf f i = k0) n (Vf f i)). have pa: lf_axiom g (csucc n) (csucc n). hnf;rewrite/g {1} sa; move => t;case /setU1_P; last by move => ->; Ytac0. move => ti;Ytac h => //; Ytac h' => //; rewrite sa; apply/setU1_r;Wtac. have sg:surjection (Lf g (csucc n) (csucc n)). apply: lf_surjective => // y; rewrite {1} sa /g; case /setU1_P. case: (equal_or_not y k0) => yk0; first by exists n => //; Ytac0. rewrite - {1} tf => /(proj2 (proj2 fb)) [x xsf fx]. rewrite sf in xsf; move: (Inm _ xsf) (Inm' _ xsf) => xa xb. by ex_tac;rewrite fx; Ytac0; Ytac0. move => ->;move: (kI) ; rewrite {1} sa; case /setU1_P. rewrite - {1} tf; move/(proj2 (proj2 fb)) => [x xsf fx]. rewrite sf in xsf; move: (Inm _ xsf) (Inm' _ xsf) =>xa xb; ex_tac. by rewrite /g; Ytac0; Ytac0. by move => kn;exists k0 => //;rewrite /g; Ytac0. set G:= (Lf g (csucc n) (csucc n)). have bg:bijection (Lf g (csucc n) (csucc n)). have cc: cardinal (source G) = cardinal (target G) by rewrite/ G; aw. have fsg: finite_set (source G). rewrite /G; aw; apply:(finite_set_nat (NS_succ nN)). exact:(bijective_if_same_finite_c_surj cc fsg sg). have gP: inc G (permutations (csucc n)). apply: Zo_i => //; apply/functionsP; rewrite /G;split;aw; fct_tac. have nf: ~ (inc n F) by move/setC1_P => []. have nk0: ~ inc k0 E by rewrite /k0; Ytac h. move: (f_equal cardinal eq0). rewrite (csucc_pr nf)(csucc_pr nk0). move/(succ_injective1 (CS_cardinal F)(CS_cardinal E)) => <-. move:(sub_smaller fIn); rewrite (card_nat nN) => le1. have le2:= cleS nN. have sub3:= proj33 (cleT le1 le2); have sub1 := (proj33 le1). have fG: function G by fct_tac. have ssG: sub (cardinal F) (source G) by rewrite /G; aw. have ssF: sub (cardinal F) (source f) by rewrite sf. ex_tac. have hh u: inc u (cardinal F) -> u <> n. by move/sub1 => iun nun; case:(nat_irreflexive nN); rewrite -{1} nun. set_extens t. move => tE;case (equal_or_not t n) => etn. move:(setU1_1 E k0); rewrite - eq0 => /setU1_P; case. rewrite {1} fv; move => /(Vf_image_P ff ssF) [u ua ub]. apply/(Vf_image_P fG ssG); ex_tac;rewrite /G; aw; last by apply:sub3. move:(hh _ ua) => nun;rewrite /g; Ytac0. by rewrite - ub; Ytac0. by move => w; case kE; rewrite w - etn. move: (setU1_r k0 tE); rewrite - eq0 => /setU1_P;case => //. rewrite {1} fv; move => /(Vf_image_P ff ssF) [u ua ub]. apply/(Vf_image_P fG ssG); ex_tac;rewrite /G; aw; last by apply:sub3. move:(hh _ ua) => nun; rewrite /g -ub;Ytac0. by Ytac h=> //; case kE; rewrite - h. move /(Vf_image_P fG ssG) => [u uik ->]; move:(sub3 _ uik)=> uIm. move:(hh _ uik) => un;rewrite /G; aw;rewrite /g; Ytac0. have: inc (Vf f u) F by rewrite fv; apply/(Vf_image_P ff ssF); ex_tac. move/setC1_P => [ha hb];Ytac h1; first by move: h1; rewrite /k0;Ytac h2. by case/setU1_P: ha. Qed. (** Enumerating a finite set of integers *) Lemma finset_enum_exists r: total_order r -> finite_set (substrate r) -> exists f, order_isomorphism f (Nint_co (cardinal (substrate r))) r. Proof. move => tor; move /NatP. move csn: (cardinal (substrate r)) => n nN. move:n nN r tor csn; apply: Nat_induction. move => r [or _] /card_nonempty se. have re:= (empty_substrate_zero se). have hb:=empty_function_bf. move: (Nintco_wor \0c) => [[o1 _] sr1]. exists empty_function; split => //; first by rewrite sr1 se Nint_co00. by move => x y ;rewrite (proj32 hb) => /in_set0. move => n nN Hrec r tor csr. have fsr:finite_set (substrate r) by apply/NatP; rewrite csr; apply:NS_succ. case: (emptyset_dichot (substrate r)) => nsr. by case: (@succ_nz n); rewrite - csr nsr cardinal_set0. move:(finite_set_torder_greatest tor fsr nsr) => [u [usr ug]]. move:(csucc_pr2 usr); set E' := (substrate r) -s1 u; rewrite csr. move/(succ_injective1(CS_nat nN) (CS_cardinal E')) => cE'. have ssr: sub E' (substrate r) by apply: sub_setC. move: (iorder_sr (proj1 tor) ssr)(total_order_sub tor ssr). set r' := induced_order r E' => sr' tor'. have ce'':cardinal (substrate r') = n by rewrite sr' - cE'. move:(Hrec _ tor' ce'') => [f' [_ _ [bf' sf' tf'] fiso]]. rewrite (proj2 (Nintco_wor n)) in sf'. have ff': function f' by fct_tac. set f := extension f' n u. move : (Nint_pr4 nN) => [ea nn]. have nn':~ inc n (source f') by rewrite sf'. have fn: Vf f n = u by apply:extension_Vf_out. have fi x: inc x (Nint n) -> Vf f x = Vf f' x. by rewrite - sf' => xx; apply:(extension_Vf_in _ ff' nn'). have sjf:surjection f by apply:extension_fs => //; exact: (proj2 bf'). have sf:source f = Nint (csucc n) by rewrite corresp_s sf'. have yf: target f = substrate r by rewrite corresp_t tf' sr'; apply: setC1_K. have ww: ~ inc u (target f') by rewrite tf' sr' => /setC1_P []. have bf: bijection_prop f (Nint (csucc n)) (substrate r). split => //; split => //; split; first fct_tac. rewrite sf - ea => a b /setU1_P asf /setU1_P bsf sv. case: asf; case:bsf => bx ax. - rewrite (fi _ ax) (fi _ bx) in sv. by apply: (proj2 (proj1 bf') a b) sv; rewrite sf'. - case: ww; rewrite - fn - bx - sv (fi _ ax); Wtac. - case: ww; rewrite - fn - ax sv (fi _ bx); Wtac. - by rewrite ax bx. move: (Nintco_wor (csucc n)) => [[or'' _] sr'']. have or := proj1 tor. exists f; split => //; first by rewrite sr''. have hu a : inc a (Nint n) -> gle r (Vf f' a) u. move => ax; apply/ug/ssr;rewrite - sr' - tf'; Wtac. hnf; rewrite sf - ea => a b /setU1_P asf /setU1_P bsf. case: asf; case:bsf => bx ax. - rewrite (fi _ ax) (fi _ bx). move: (fiso a b); rewrite sf' => sa; move: (sa ax bx) => H. move/(NintP nN): (bx) => lbn. have lbn':=(clt_ltT lbn (cltS nN)). have ha: gle (Nint_co n) a b <-> a <=c b. by apply: (iff_trans (Nintco_gleP nN a b)); split => //; move/proj1. have hb: gle (Nint_co (csucc n)) a b <-> a <=c b. by apply:(iff_trans (Nintco_gleP (NS_succ nN) a b)); split => //; move/proj1. apply:(iff_trans (iff_trans hb (iff_trans (iff_sym ha) H))). apply:iorder_gleP; rewrite - sr' - tf'; Wtac. - rewrite (fi _ ax) bx fn; split => _; first exact:(hu _ ax). apply/(Nintco_gleP (NS_succ nN)); split; last exact:(cltS nN). by move/(NintP nN):ax => []. - rewrite (fi _ bx) ax fn; split. by move/(Nintco_gleP (NS_succ nN)) => [/cleNgt /(NintP nN)]. move => le1; case: ww; rewrite(order_antisymmetry or le1 (hu _ bx)); Wtac. - rewrite bx ax fn; split => _; apply/order_reflexivityP => //. by rewrite sr''; apply: (Nint_si nN). Qed. Lemma finset_enum_unique r f f': order_isomorphism f (Nint_co (cardinal (substrate r))) r -> order_isomorphism f' (Nint_co (cardinal (substrate r))) r -> f = f'. Proof. move => ha hb. apply:(iso_unique (proj1 (Nintco_wor (cardinal (substrate r)))) ha hb). Qed. Definition nth_more K S := S +s1 intersection (K -s S). Definition nth_elts K := induction_term (fun _ S => nth_more K S) emptyset. Lemma nth_set0 x (y := intersection x) : x = emptyset -> y = \0c. Proof. by rewrite /y;move => ->; rewrite setI_0. Qed. Lemma nth_set2 K S: sub K S -> nth_more K S = S +s1 \0c. Proof. by move => h; rewrite /nth_more (setC_T h) setI_0. Qed. Lemma nth_set3 K: nth_more K K = K +s1 \0c. Proof. by apply:nth_set2. Qed. Definition segment_nat K S:= sub S K /\ (forall i j, inc i S -> inc j (K -s S) -> i segment_nat K S -> S <> K -> [/\ segment_nat K S', inc x (S' -s S) & cardinal S' = csucc (cardinal S)]. Proof. move => KN [sa sb sc]. have sd:=(setC_ne (conj sa sc)). have se:=(sub_trans (@sub_setC K S) KN). move:(inf_Nat se sd); rewrite -/x; move => [/setC_P [xK xS] xm]. split; first split. + by move => t /setU1_P; case; [move /sa | move => ->]. + move => i j /setU1_P iv /setC_P [jK /setU1_P jv]. have aux: inc j (K -s S) by apply/setC_P; split => //;dneg js; left. case iv; first by move => iS; apply: sb => //. by rewrite -/x => ->; split; [ apply: xm | dneg h; right]. + by apply/setC_P; split; [ apply:setU1_1 | ]. + by rewrite csucc_pr. Qed. Lemma nth_elts0 K: nth_elts K \0c = emptyset. Proof. by apply:induction_term0. Qed. Lemma nth_elts_succ K n: natp n -> nth_elts K (csucc n) = nth_more K (nth_elts K n). Proof. apply:induction_terms. Qed. Lemma nth_set5 K n (S:= nth_elts K n): natp n -> sub K Nat -> n <=c cardinal K -> (segment_nat K S /\ cardinal S = n). Proof. rewrite /S => nN kN;move: n {S} nN; apply: Nat_induction. move => _; rewrite nth_elts0 cardinal_set0; split => //; split=> i. by move/in_set0. by move => j /in_set0. move => n nN Hrec snk. rewrite /nth_elts (induction_terms _ _ nN) -/(nth_elts K n). move:(Hrec (cleT (cleS nN) snk)) => [sa sb]. case (equal_or_not (nth_elts K n) K) => nsK. by move: (proj2 (clt_leT (cltS nN) snk)); rewrite - nsK sb. by move: (nth_set4 kN sa nsK); rewrite sb; move => [ua _ ub]. Qed. Lemma nth_set6 K (n:= cardinal K): natp n -> sub K Nat -> (nth_elts K n) = K. Proof. move => nN kN. move: (nth_set5 nN kN (cleR (CS_nat nN))) => [[sa _] sb]. have fsk: finite_set K by apply /NatP. move: (cardinal_setC4 sa fsk); rewrite sb cdiff_nn. by move /card_nonempty => /empty_setC h; apply: extensionality. Qed. Lemma nth_set_M K n m: natp n -> m <=c n -> sub (nth_elts K m) (nth_elts K n). Proof. move => nN mn. rewrite - (cdiff_pr mn). move:(NS_diff m nN); set k:= (n -c m) => kN. move:(NS_le_nat mn nN) => mN; move: k kN;clear n mn nN. apply: Nat_induction; first by rewrite (csum0r (CS_nat mN)). move => n nN hrec. rewrite (csum_nS _ nN) (nth_elts_succ _ (NS_sum mN nN)). apply /(sub_trans hrec) /subsetU2l. Qed. Definition nth_elt K n := union (nth_elts K (csucc n) -s nth_elts K n). Lemma nth_set7 K n (S:= (nth_elts K n)) (x:= nth_elt K n) : natp n-> sub K Nat -> n [/\ inc x (K -s S), inc x (nth_elts K (csucc n)), forall y, inc y (K -s S) -> x <=c y & forall y, inc y S -> y nN KN h1. have [[SK sw] cs1]:= (nth_set5 nN KN (proj1 h1)). have pa: sub (K -s S) Nat by move => t/setC_P [/ KN h _]. case: (emptyset_dichot (K -s S)) => nek. by case: (proj2 h1); rewrite - cs1 {2} (extensionality (empty_setC nek) SK). have h2: csucc n <=c cardinal K by apply /(cleSltP nN). move: (inf_Nat pa nek). set I := intersection (K -s S); move => [sa sb]. have /setCId_Pl di: disjoint (singleton I) S. by apply: disjoint_pr => u /set1_P -> eis; case/setC_P: sa => _. move: (erefl x); rewrite {1} /x /nth_elt /nth_elts (induction_terms _ _ nN). rewrite -/(nth_elts K n) /nth_more -/S -/I setCU2_l setC_v set0_U2 di setU_1. by move => <-; split; fprops; move => y ys; apply: sw. Qed. Lemma nth_set9 K n: natp n -> sub K Nat -> n inc (nth_elt K n) K. Proof. by move => pa pb pc; move:(nth_set7 pa pb pc) => [/setC_P []]. Qed. Lemma nth_set8 K n m: inc n Nat -> sub K Nat -> n m (nth_elt K m) nN KN nk mn. have mN:= (NS_lt_nat mn nN). apply: (proj44 (nth_set7 nN KN nk)). have ub:= (proj42 (nth_set7 mN KN (clt_ltT mn nk))). move /(cleSltP mN): mn => le1. exact:(nth_set_M nN le1 ub). Qed. Definition nth_set_fct K := Lf (nth_elt K) (cardinal K) K. Lemma nth_set_fct_bf K (f := (nth_set_fct K)): sub K Nat -> finite_set K -> (bijection (nth_set_fct K) /\ forall i j, inc i (source f) -> inc j (source f) -> i Vf f i KN /NatP kN. have ax: lf_axiom (nth_elt K) (cardinal K) K. move => n /(NltP kN) nk. by move:(nth_set7 (NS_lt_nat nk kN) KN nk) => [/setC_P [h _] _ _ _]. have sf: source f = (cardinal K) by rewrite /f/nth_set_fct;aw. have pa: forall i j, inc i (source f) -> inc j (source f) -> i Vf f i i j isf jsf; aw. move/(NltP kN): jsf => jk. by apply:nth_set8 => //; apply:(NS_lt_nat jk kN). split; last by exact. rewrite sf in pa. have fi: injection f. apply: lf_injective => // u v usf vsf sv. case: (NleT_ell (NS_inc_nat kN usf) (NS_inc_nat kN vsf)) => cp //. by move: (proj2 (pa _ _ usf vsf cp)); rewrite /f/nth_set_fct;aw; case. by move: (proj2 (pa _ _ vsf usf cp)); rewrite /f/nth_set_fct;aw; case. apply: bijective_if_same_finite_c_inj => //;rewrite /nth_set_fct; aw. exact: double_cardinal. exact: (finite_set_nat kN). Qed. Lemma nth_set_10 K a: sub K Nat -> finite_set K -> inc a K -> exists2 n, n ha hb aK; move:( nth_set_fct_bf ha hb) => [[_ [ff fs]] _]. have hc: natp (cardinal K) by apply/NatP. have ax:lf_axiom (nth_elt K) (cardinal K) K. move => t /(NltP hc) ta; apply:(nth_set9 _ ha ta). exact:(NS_lt_nat ta hc). move:fs; rewrite /nth_set_fct; aw => fs; move:(fs _ aK) => [x xa]. by aw => <-; exists x => //; apply/(NltP hc). Qed. Lemma nth_set_exten k f: natp k -> (forall i, i natp (f i)) -> (forall i j, i j f i (forall i, i (nth_elt (fun_image k f) i = f i)). Proof. move => kN ha hb. set K := (fun_image k f). have Ka: sub K Nat by move => z /funI_P [i /(NltP kN) lik ->]; apply: ha. move:(Nintco_wor k) => [wor1 sr1]; move: (proj1 wor1) => or1. have csK: cardinal_set K by move => t /Ka /CS_nat. move:(wordering_cle_pr csK) => [[]]. set r2 := graph_on cardinal_le K => or2 _ sr2. have hc:lf_axiom f k K by move => t tk; apply/funI_P; ex_tac. have hd:function_prop (Lf f k K) k K. by split; aw; apply:lf_function. have he x y: inc y k -> (gle (Nint_co k) x y <-> x <=c y). move => /(NltP kN) yk; split; first by move => /(Nintco_gleP kN) []. by move => lxy; apply /(Nintco_gleP kN). have hf x y: inc x K -> inc y K -> (x <=c y <-> gle r2 x y). move => xK yK; split => h; first by apply/graph_on_P1. by move/graph_on_P1: h => []. have finj:{inc k &, injective f}. move => i j /(NltP kN) lik /(NltP kN) ljk sf. case:(cleT_ell (proj31_1 lik) (proj31_1 ljk)) => // lij. - by case: (proj2 (hb _ _ lij ljk)); rewrite sf. - by case: (proj2 (hb _ _ lij lik)); rewrite sf. have hg: bijection_prop (Lf f k K) k K. by split;aw;apply:lf_bijective => // y /funI_P. have sf1: order_isomorphism (Lf f k K) (Nint_co k) r2. split => //; first by rewrite sr1 sr2 (NintE kN). hnf; aw => x y xK yK; aw;apply:(iff_trans (he x y yK)). move: (hc _ xK) (hc _ yK) => fxk fyk. move/(NltP kN):(yK) => lyk;move/(NltP kN):(xK) => lxk. apply: (iff_trans _ (hf _ _ fxk fyk)). case:(cleT_ell (proj31_1 lxk) (proj31_1 lyk)) => lxy. - rewrite lxy; split => _; apply:cleR; first exact: (CS_nat (Ka _ fyk)). exact (proj31_1 lyk). - split => h; [ exact (proj1 (hb _ _ lxy lyk)) | exact:(proj1 lxy) ]. - by split => h; [ move:(cltNge lxy h) | case:(cltNge (hb _ _ lxy lxk) h)]. have Kb: cardinal K = k. by rewrite - (card_nat kN); apply:cardinal_fun_image. have aux: natp (cardinal K) by rewrite Kb. have fsK: finite_set K by apply/NatP. have hc': lf_axiom (nth_elt K) k K. move => t /(NltP kN) tb; apply:(nth_set9 (NS_lt_nat tb kN) Ka); ue. have hd':function_prop (Lf (nth_elt K) k K) k K. by split; aw; apply:lf_function. have hg' : bijection_prop (Lf (nth_elt K) k K) k K. by split; aw; move:(proj1 (nth_set_fct_bf Ka fsK)); rewrite /nth_set_fct Kb. have sf2: order_isomorphism (Lf (nth_elt K) k K) (Nint_co k) r2. split => //; first by rewrite sr1 sr2 (NintE kN). hnf; aw => x y xK yK; aw;apply:(iff_trans (he x y yK)). move: (hc' _ xK) (hc' _ yK) => fxk fyk. move/(NltP kN):(yK) => lyk;move/(NltP kN):(xK) => lxk. apply: (iff_trans _ (hf _ _ fxk fyk)). case:(cleT_ell (proj31_1 lxk) (proj31_1 lyk)) => lxy. - rewrite lxy; split => _; apply:cleR; first exact: (CS_nat (Ka _ fyk)). exact (proj31_1 lyk). - split => h; last by exact:(proj1 lxy). have yb: y h; first by move:(cltNge lxy h). have xb: x i /(NltP kN) ik. move: (f_equal (Vf^~i) (iso_unique wor1 sf2 sf1)); aw. Qed. (** partitions *) 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: gfunctions_i; apply: function_pr =>// 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 -> csum p = cardinal E -> nonempty (partitions_pi p E). Proof. move=> fif. move /card_eqP => [f [[injf [ff 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. exists (Lg (domain p) (fun i => Vfs f (k i))); apply /partitions_piP. split; first bw. move=> i idp; rewrite /k;bw. rewrite -{2} (card_card (fif_cardinal fif idp)). by rewrite (cardinal_image (sx _ idp) injf) cardinal_indexed. split; first fprops. 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]. rewrite Wv in Wu. have uv:=(proj2 injf _ _ (p2 _ vkj) (p1 _ uki) Wu). move: uki vkj; rewrite uv /k. by move /indexed_P => [_ _ <-] /indexed_P [_ _ <-]. rewrite -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: (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 exists y => //; apply /indexed_P. Qed. Definition partitions_aux f g:= Lg (domain f) (fun i => Vfs 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 [/functionsP [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]]. hnf; rewrite / partitions_aux; bw; split => //. rewrite df;move=> i idp; bw; rewrite - (cVg _ idp) ; symmetry. apply /card_eqP/Eq_restriction1 =>//; apply: Ha =>//; ue. split;fprops. apply: mutually_disjoint_prop=>//; bw => i j y idp jdp; bw. move: (Ha _ idp) (Ha _ jdp)=> s1 s2. 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. case: (duj _ _ idp jdp) => //; rewrite /disjoint => ns. rewrite -uv in vi; 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 -> csum 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 hnf;rewrite - spE; apply /NatP /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; 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. hnf in dujy; rewrite dy -df in dujy. case: (dujy _ _ u'd v'd) =>// h1; rewrite eq in Wu; empty_tac1 (Vf g v). have pg: inc g (permutations E) by apply: permutation_if_inj. 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) /h; aw; apply: ta1 =>//; ue. rewrite -tha. set_extens u. 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 <-]. rewrite sha in vs; rewrite - (p3 _ vs); apply /(Vf_image_P fg p2a); ex_tac. Qed. Lemma number_of_partitions5P p E f g h: finite_int_fam p -> csum 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) -> Vfs ( (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 [] /functionsP [fh sh th] [inh [_ sjh]]. move => /Zo_P [] /functionsP [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 /Vfs/inverse_fun/compose; aw. set_extens x. move /dirim_P => [y yW /compg_pP [z pa /igraph_pP pb]]. have : inc z (Vfs g (Vg f i)) by apply /dirim_P; ex_tac. rewrite eql; move /dirim_P => [x' x'Vf Jg2]. by rewrite (injective_pr3 inh pb Jg2). move=> xW. have xsh: inc x (source h) by rewrite sh; apply: (Ht _ idp). have : (inc (Vf h x) (Vfs 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: (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'/Vfs/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 -> csum 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 [] /functionsP [fh sh th] bh. move=> /Zo_P [] /functionsP [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)). hnf; aw; split => //; ue. have fk: (function k) by rewrite /k; apply: (proj31(restriction2_prop ra)). apply:permutation_if_inj. - rewrite /finite_set;move: pip fip => [_ pip _] [hp _ ]. by rewrite (pip _ idp); apply/NatP; apply: hp. - done. 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 _ _ xsg ysg). 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 -> csum 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]]; move: (proj33 pip) => pfa. rewrite df in sWE. set ww:=Lf _ _ _. move: (number_of_partitions6 fip spE pip hp) => ta. move:(hp) => /Zo_P [] /functionsP [fh sh th] bh. have bih: (bijection (inverse_fun h)) by apply: inverse_bij_fb. have fw: function ww by apply: lf_function. have sw: surjection ww. split => // y. rewrite {1 2} /ww; aw; move /setXb_P; bw; move=> [fgy dy yp]. have yp': (forall i, inc i (domain p) -> (bijection_prop (Vg y i) (Vg f i) (Vg f i))). by move=> i idp;move: (yp _ idp); bw;move => /Zo_P [/functionsP [? ? ?] ?]. have ta1: (forall i, inc i (domain p) -> lf_axiom (Vf (Vg y i)) (Vg f i) E). move=> i idp z zW; move: (yp' _ idp)=> [bha sha tha]. apply: (sWE _ idp); rewrite -tha;Wtac; fct_tac. pose hb i := Lf (Vf (Vg y i)) (Vg f i) E. 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. move : (ta1 _ ap) (ta1 _ bp) => ta2 ta3. rewrite (p3 _ ua)(q3 _ vb) /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 (Vg y a) u). - rewrite /Vf in tha;rewrite -tha; Wtac; fct_tac. - rewrite /Vf in thb;rewrite h2 -thb; Wtac; fct_tac. have gp: inc g (permutations E). apply:permutation_if_inj => //. apply /NatP; rewrite - spE; apply: finite_sum_finite =>//. move/permutationsP:(gp) => [bg _ _]. have pa:forall i v, inc i(domain p) -> inc v (Vg f i) -> Vf g v = Vf (Vg y 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. set (t:= h \co g). have pt: inc t (permutations E) by apply (permutation_Sc hp gp). 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 pb; case: (duj _ _ idp jd) => di. rewrite -di in bW; ex_tac. rewrite /t /compose; aw; apply /compg_pP; ex_tac; rewrite -Wb; Wtac. empty_tac1 a; rewrite -Wb;apply: (pb _ _ jd bW). ex_tac; rewrite (lf_V ta xz). rewrite /t (permutation_lK hp gp). apply: fgraph_exten;bw; fprops => 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) => [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). move: eq2 => /(number_of_partitions5P fip spE pip hp ys). set xi:= _ \co x; set yi:= _ \co y => eq2 eq1 eq. suff: xi = yi. rewrite /xi /yi;move => eqi; move: (f_equal (compose h) eqi). by rewrite (permutation_lK' hp xs)(permutation_lK' hp ys). move:(permutation_Si hp) => hp'. move:(permutation_Sc hp' xs) => /permutationsP[ /proj1/proj1 bxi sxi txi]. move:(permutation_Sc hp' ys) => /permutationsP[ /proj1/proj1 byi syi tyi]. apply: (function_exten bxi byi). by rewrite sxi syi. by rewrite txi 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 (num:= factorial (cardinal E)) (den := cprod (Lg (domain p) (fun z => factorial (Vg p z)))): finite_int_fam p -> csum p = cardinal E -> [/\ num = cardinal (partitions_pi p E) *c den, natp num, natp den, den <> \0c & finite_set (partitions_pi p E)]. Proof. move => fip spe. move: (number_of_partitions1 fip spe)=> [h hp]. have Hb: finite_set E. by hnf; rewrite - spe; apply /NatP; apply: finite_sum_finite=> //. have numN: natp num by rewrite /num; apply: NS_factorial; apply /NatP; aw. have ndenN: natp den. move: fip=> [p2 p3]. rewrite /den;apply: finite_product_finite =>//. by hnf; bw;split => //; hnf; bw => i idp; bw; apply: NS_factorial; apply: p2. have nd:den <> \0c. move: fip=> [p2 p3]. apply /cprod_nzP; hnf;bw => i idp; bw; apply: factorial_nz; apply: p2=>//. rewrite /finite_set; set aux:= cardinal _. suff: num = aux *c den. move => eql; split => //. have ca: cardinalp aux by apply: CS_cardinal. by apply /NatP; apply: (Nat_in_product ca nd); ue. 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 (Vfi1 phi 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: Eq_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) card_card //; apply: (CS_nat (NS_factorial (q2 _ idp))). hnf; rewrite p2 //; apply /NatP; 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 -> csum p = cardinal E -> cardinal (partitions_pi p E) = (factorial (cardinal E)) %/c (cprodb (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)). move=> [p1 p2 p3 p4] /NatP p5. rewrite p1 cprodC; symmetry; apply: cdivides_pr4 =>//. Qed. Lemma number_of_partitions_p2 E m p (num := factorial (m +c p)) (den := (factorial m) *c (factorial p)) (x := cardinal (partitions_pi (variantLc m p) E)): natp m -> natp p -> cardinal E = (m +c p) -> [/\ natp x, num = x *c den,natp num, natp den & den <> \0c]. Proof. move=> mN pN cE. set P:= variantLc m p. have h1: finite_int_fam P. rewrite /P;split;fprops. by hnf; bw; move=> i it; try_lvariant it. bw;apply: set2_finite. have p2: csum P = cardinal E. symmetry;rewrite cE /csum2/csum; fprops. move: (number_of_partitions h1 p2); simpl. set y:= cprod _. have -> : den = y. rewrite /den/cprod2/y/P; bw. apply:cprodb_exten. 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 Nat (fun z => variant \0c \1c (Vg T z +c Vg T (cpred z)) z)) (Lg Nat (variant \0c \1c \0c)) n) m. Lemma binom00: binom \0c \0c = \1c. Proof. rewrite /binom induction_term0 /variant; bw; [ by Ytac0 | apply:NS0 ]. Qed. Lemma binom0Sm m: natp m -> binom \0c (csucc m) = \0c. Proof. move=> mN; have snz := (@succ_nz m). by rewrite /binom /variant induction_term0; bw; [ Ytac0 | apply: NS_succ]. Qed. Lemma binomSn0 n: natp n -> binom (csucc n) \0c = \1c. Proof. move=> nN; rewrite /binom /variant induction_terms //. bw; [by Ytac0 | apply: NS0]. Qed. Lemma binomSnSm n m: natp n -> natp m -> binom (csucc n) (csucc m) = (binom n (csucc m)) +c (binom n m). Proof. move=> nN mN. rewrite /binom /variant induction_terms //. have snz := (@succ_nz m). bw; [Ytac0; rewrite cpred_pr1 //; fprops | by apply:NS_succ ]. Qed. Lemma NS_binom n m: natp n -> natp m -> natp (binom n m). Proof. move=> nN; move: n nN m; apply: Nat_induction. apply: Nat_induction; first by rewrite binom00=>//; fprops. move => n nN _; rewrite binom0Sm; fprops. move => n nN hrec; apply: Nat_induction; first by rewrite binomSn0; fprops. move => p pN bN; rewrite binomSnSm; fprops. Qed. Lemma binom_alt_pr n m: natp n -> natp m -> (binom n m) *c (factorial m) *c (factorial (n -c m)) = Yo (m <=c n) (factorial n) \0c. Proof. move: n m. pose Bi n m := (binom n m) *c (factorial m *c (factorial (n -c m))). have ba4: forall n m, natp n -> natp m -> Bi (csucc n) (csucc m)= ((Bi n (csucc m)) *c (Yo (n <=c m) \1c (n -c m))) +c (Bi n m *c csucc m). move=> n m nN mN. rewrite /Bi binomSnSm // cdiff_pr6 // cprodDr. set aux := (factorial (csucc m)) *c (factorial (n -c m)). set A:= (binom n (csucc m)) *c aux. suff: A = (Bi n (csucc m)) *c (Yo (n <=c m) \1c (n -c m)). move => ->; congr (_ +c _); rewrite - cprodA; congr (_ *c _). by rewrite (cprodC (factorial m) _) - cprodA -(factorial_succ mN) cprodC. rewrite /A /Bi /aux - 2! cprodA; apply:f_equal; apply:f_equal. case: (p_or_not_p (n <=c m)) => le; Ytac0. rewrite (Nprod1r (NS_factorial (NS_diff (csucc m) nN))). by rewrite (cdiff_wrong (cleT le (cleS mN))) (cdiff_wrong le). case: (NleT_el nN mN) => // /(cleSltP mN) /(csucc_diff nN mN) s. rewrite s factorial_succ; fprops. move=> n m nN mN. rewrite - cprodA -/(Bi n m); move: n nN m mN; apply: Nat_induction. move=> m mN. rewrite /Bi cdiff_0n factorial0 (Nprod1r (NS_factorial mN)). move: m mN; apply: Nat_induction. rewrite binom00 factorial0; aw; fprops; rewrite Y_true; fprops. move=> p pN aux; Ytac h; first by move: (cleNgt h (succ_positive p)). by rewrite binom0Sm // cprod0l. move=> N NN rN; apply: Nat_induction. move: (NS_succ NN) => sN; move: (NS_factorial sN) => fN. rewrite /Bi (binomSn0 NN)(cdiff_n0 sN)factorial0 !(Nprod1l fN) Y_true;fprops. move => p pN bN. rewrite (ba4 _ _ NN pN) (rN _ pN)(rN _ (NS_succ pN)) factorial_succ //. case: (NleT_el (NS_succ pN) NN) => c1. have lepN:=(cleT (cleS pN) c1). case: (p_or_not_p (N <=c p)) => h; first case:(cleNgt (cleT c1 h) (cltS pN)). rewrite (Y_true c1)(Y_true lepN)(Y_true (cleT c1 (cleS NN))) (Y_false h). by rewrite - cprodDl (Nsucc_rw pN) (Nsucc_rw NN) csumA (cdiff_rpr lepN). move /(cltSleP pN): (c1) => c2. rewrite (Y_false (cltNge c1)) cprod0l. case: (equal_or_not N p) => epN. rewrite - epN (Y_true (cleR (CS_nat NN))) csum0l ? Y_true; fprops. move:(cltNge (conj c2 epN)) => c3. move /(cleSSP (proj32 c2) (proj31 c2)): (c3) => c4. by Ytac0; Ytac0; rewrite cprod0l // (Nsum0l NS0). Qed. Lemma binom_bad n m: natp n -> natp m -> n binom n m = \0c. Proof. move=> nN mN h; move: (factorial_nz mN) (factorial_nz (NS_diff m nN))=> sa sb. move: (binom_alt_pr nN mN). by rewrite (Y_false (cltNge h)) => /cprod2_eq0; case => //;case/cprod2_eq0. Qed. Lemma binom_good n m: natp n -> natp m -> m <=c n -> (binom n m) *c (factorial m) *c (factorial (n -c m)) = (factorial n). Proof. by move=> nN mN h; move: (binom_alt_pr nN mN); Ytac0. Qed. Lemma binom_pr0 n p (num := factorial n) (den:= (factorial p) *c (factorial (n -c p))): natp n -> natp p -> p <=c n -> den %|c num /\ binom n p = num %/c den. Proof. move=> nN pN h; move: (binom_good nN pN h). have nuN: natp num by apply: NS_factorial =>//. have deN: natp den by apply: NS_prod;apply: NS_factorial; fprops. have dnz: den <> \0c. rewrite /den; apply: cprod2_nz; apply: factorial_nz; fprops. have bN: natp (binom n p) by apply: NS_binom =>//. rewrite - cprodA cprodC -/num => <-. by split; [ apply:cdivides_pr1 |rewrite cdivides_pr4 ]. Qed. Lemma binom_pr1 n p: natp n -> natp p -> p <=c n -> binom n p = (factorial n) %/c ((factorial p) *c (factorial (n -c p))). Proof. by move=> nN pN h; move: (binom_pr0 nN pN h)=> [_]. Qed. Lemma binom_symmetric n p: natp n -> p <=c n -> binom n p = binom n (n -c p). Proof. move => nN h. move: (NS_le_nat h nN) => pN. move: (cdiff_ab_le_a p (CS_nat nN)) => aux. rewrite (binom_pr1 nN pN h) cprodC (binom_pr1 nN (NS_diff p nN) aux). rewrite double_diff //; apply: le_minus. Qed. Lemma binom_symmetric2 n m: natp n -> natp m -> binom (n +c m) m = binom (n +c m) n. Proof. move => nN mN. rewrite csumC (binom_symmetric (NS_sum mN nN) (Nsum_M0le n mN)). rewrite csumC (cdiff_pr1 nN mN) //. Qed. Lemma binom0 n: natp n -> binom n \0c = \1c. Proof. move=> nN. case: (equal_or_not n \0c) => nz; first by rewrite nz binom00. move: (cpred_pr nN nz)=> [pN ->]; rewrite binomSn0 //. Qed. Lemma binom1 n: natp n -> binom n \1c = n. Proof. move: n; rewrite - succ_zero;apply: Nat_induction. rewrite binom0Sm; fprops. move=> p pN r. by rewrite (binomSnSm pN NS0) r (binom0 pN) (Nsucc_rw pN). Qed. Lemma binom2a n: natp n -> \2c *c (binom (csucc n) \2c) = n *c (csucc n). Proof. move:n ; rewrite -{2} succ_one; apply: Nat_induction. rewrite cprod0l (binomSnSm NS0 NS1) (binom0Sm NS1) (binom1 NS0). by rewrite (Nsum0r NS0) cprod0r. move=> n nN r; move: (NS_succ nN) => sN. rewrite (binomSnSm sN NS1) cprodDl r (binom1 sN) - cprodDr cprodC. by rewrite - card_two_pr (Nsucc_rw sN) (Nsucc_rw nN) csumA. Qed. Lemma binom2 n: natp n -> binom (csucc n) \2c = (n *c (csucc n)) %/c \2c. Proof. move=> nN; move: (NS_succ nN) => sN. apply: (cdivides_pr2 (NS_prod nN sN) NS2 (NS_binom sN NS2) card2_nz). by rewrite (binom2a nN). Qed. Lemma binom_nn n: natp n -> binom n n = \1c. Proof. move=> nN. rewrite (binom_symmetric nN (cleR (CS_nat nN))) cdiff_nn binom0 =>//. Qed. Lemma binom_pr3 n p: natp n -> natp p -> p <=c n -> binom n p <> \0c. Proof. move=> nN pN h bz; move: (binom_good nN pN h). rewrite bz - cprodA cprod0l => fz. by case: (factorial_nz nN). Qed. Lemma binom_monotone1 k n m: natp k -> natp n -> natp m -> k <> \0c -> k <=c (csucc n) -> n (binom n k) natp n -> k <> \0c -> k <=c (csucc n) -> (binom n k) k n kN nN r1 r2. move: (cpred_pr kN r1) => [pN ps]. rewrite {2} ps (binomSnSm nN pN) -ps. apply: (csum_M0lt (NS_binom nN kN));apply: binom_pr3 =>//. apply /(cleSSP (CS_nat pN) (CS_nat nN)); rewrite -ps//. move=> aux k n m kN nN mN r1 r2 r3. move/(cleSltP nN): r3 => r6. have r8:= cleR (CS_nat mN). pose r p := (binom n k) n' r4 r5 r7;apply:(clt_ltT r7). apply: (aux _ _ kN (NS_lt_nat r5 mN) r1). exact:(cleT (cleT r2 r4) (cleS0 (proj32 r4))). Qed. Lemma binom_monotone2 k n m: natp k -> natp n -> natp m -> k <> \0c -> k <=c (csucc n) -> k <=c (csucc m) -> (n (binom n k) kN nN mN r1 r2 r3. split; first by apply: binom_monotone1. case: (cleT_el (CS_nat mN) (CS_nat nN)) => // mn [ble bne]. case: (equal_or_not m n) => nm; first by case: bne; rewrite nm. have bgt: (binom m k) natp p -> cardinal E = m +c p -> cardinal (partitions_pi (variantLc m p) E) = binom (m +c p) m. Proof. move=> mN pN cE; move: (number_of_partitions_p2 mN pN 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. by rewrite (cdivides_pr2 p3 p4 p1 p5 p2) (binom_pr1 (NS_sum mN pN) mN r1) r2. Qed. Lemma number_of_partitions_p4 E n m: natp n -> natp m -> cardinal E = n -> cardinal (partitions_pi (variantLc m (n -c m)) E) = binom n m. Proof. move=> nN mN cE. case: (NleT_el mN nN) => mn. rewrite -(cdiff_pr mn) in cE. by rewrite (number_of_partitions_p3 mN (NS_diff m nN) cE) (cdiff_pr mn). rewrite binom_bad // (cdiff_wrong (proj1 mn)). have cE': cardinal E = n +c \0c by aw; fprops. set w := partitions_pi _ E; case: (emptyset_dichot w). move=> ->; apply: cardinal_set0. move=> [t] /partitions_piP pip. have [df cVg [fgf duj ue]] := pip. have aux:= (pip_prop0 pip). have ad: inc C0 (domain (variantLc m \0c)) by bw; fprops. move: (cVg _ ad); bw=> eq1. have tA:inc C0 (domain t) by rewrite df; bw; fprops. by move: (sub_smaller (aux _ tA)); rewrite eq1 cE => /(cltNge mn). 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: natp n -> natp p -> cardinal E = n -> binom n p = cardinal (subsets_with_p_elements p E). Proof. move=> nN pN 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: (cleT_el cp cn); last first. move=> np; rewrite binom_bad//. case: (emptyset_dichot trg); first by move=> ->; rewrite cardinal_set0. move=> [y] /Zo_P [] /setP_P yE cy. by move: (sub_smaller yE); rewrite cEn cy =>/(cltNge np). move=> pn. move:(cdiff_pr pn) (NS_diff p nN) => ps sN. move: (cEn); rewrite -ps; move=> cEn'. rewrite -(number_of_partitions_p3 pN sN 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; first by move: ((pip_prop0 pip) _ ta) => /setP_P. move: (proj32 pip); bw =>cp'; rewrite (cp' _ inc_C0_C2); bw. - have aux: forall w, inc w src -> (Vg w C1 = E -s (Vg w C0)). move=> w /partitions_piP [df cVg [fgf duj ue]]. have dgw: (domain w = C2) by rewrite df; bw. rewrite /mutually_disjoint dgw in duj. case: (duj _ _ inc_C0_C2 inc_C1_C2) => di1; first by case:C1_ne_C0. 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. by 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 /NatP; ue. Qed. Lemma subsets_with_p_elements_pr0 n p: natp n -> natp p -> binom n p = cardinal (subsets_with_p_elements p n). Proof. move=> nN pN. by rewrite (subsets_with_p_elements_pr nN pN (card_nat nN)). Qed. Lemma bijective_complement n p E: natp n -> natp p -> 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=> nN pN 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 /NatP; 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; first by apply /setP_P; apply: sub_setC. have fse: finite_set E by apply /NatP; ue. rewrite (cardinal_setC4 yE fse) cy cE; apply: double_diff => //. Qed. Definition functions_sum_eq E n:= Zo (functions E (Nintc n)) (fun z=> csum (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 (Nintc n)) (fun z=> csum (P z) <=c n). Definition graphs_sum_le F n:= fun_image (functions_sum_le F n) graph. Lemma setof_suml_auxP F n: natp n -> forall f, inc f (graphs_sum_le F n) <-> [/\ domain f = F, (csum f) <=c n, fgraph f & cardinal_fam f]. Proof. move=> nN f. split. move=> /funI_P [z /Zo_P [/functionsP [ fz sz tz] cs] ->]. split; [rewrite - sz; aw | exact | fprops | ]. move=> i; rewrite -(proj33 fz) => iz. by move: (Vf_target fz iz); rewrite tz => /Nint_S /CS_nat. move=> [df sf fgf alc]. have tf: forall i, inc i F -> inc (Vg f i) (Nintc n). rewrite -df;move=> i iF. have sjd: sub (singleton i) (domain f) by move=> t /set1_P->. move: (csum_increasing1 alc sjd). rewrite /restr -/(csumb _ _) csum_trivial3 (card_card (alc _ iF)) => ha. apply/(NintcP nN); exact:(cleT ha sf). set z:= triple F (Nintc n) f. apply /funI_P;exists z; rewrite /z => //; aw. apply: Zo_i=> //; last by rewrite /triple; aw. apply /functionsP;split => //; aw; apply: function_pr => //. move=> t /(range_gP fgf) [x xs ->]; apply: tf; ue. Qed. Lemma setof_sume_auxP F n: natp n -> forall f, inc f (graphs_sum_eq F n) <-> [/\ domain f = F, csum f = n, fgraph f& cardinal_fam f]. Proof. move=> nN f; split. move=> /funI_P [z /Zo_P [/functionsP [ fz sz tz] cs] ->];split => //. - rewrite - sz; aw. - fprops. - move=> i; rewrite -(proj33 fz) => iz. by move: (Vf_target fz iz); rewrite tz => /Nint_S /CS_nat. 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: natp n -> cardinal E = n -> csumb (graphs_sum_eq F n) (fun p => cardinal (partitions_pi p E)) = (cardinal F) ^c n. Proof. move=> cE cEn. rewrite - {2}cEn cpowcr cpowcl. pose g f i:= (Vfi1 f 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 /functionsP [ff sf tf]. have sfa: (source f = unionb (Lg (target f) (g f))). set_extens t. move => tsf; apply /setUb_P; bw. have Wt := (Vf_target ff tsf). ex_tac; bw; apply /iim_fun_set1_i => //. move => /setUb_P; bw; move => [y ytg]; bw => h. by case /(iim_fun_set1_P _ ff): h. have md: mutually_disjoint (Lg (target f) (g f)). apply: mutually_disjoint_prop2 => 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; hnf; bw;split => //. move => i iF; bw. hnf; rewrite -tf;split;fprops; ue. rewrite /f1; apply /(setof_sume_auxP _ cE);bw; rewrite /cardinal_fam /allf. split; [exact | rewrite - cEn - sf sfa | fprops | bw => i iF; bw; fprops ]. apply /card_eqP; apply: equipotent_disjointU => //. rewrite /disjointU_fam; hnf;bw; split;fprops. move=> i itf; bw; last by ue. by apply/card_eqP; rewrite cardinal_indexed double_cardinal. 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. apply:(@EqT (partitions_pi i E)); last first. by apply/card_eqP; rewrite cardinal_indexed double_cardinal. 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 [] /functionsP [fu su tu] f1u /Zo_P [] /functionsP [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 (Vfi1 u (Vf u x))). by apply: iim_fun_set1_i. by rewrite ieq; move /(iim_fun_set1_hi fv). move=> y /partitions_piP ys. have pip0 := (pip_prop0 ys). have [df cVg [fgf duj ue]] := ys. have doi: domain i = F by move /(setof_sume_auxP _ cE): id => []. rewrite doi in cVg. pose p x j := inc j F /\ inc x (Vg y j); pose xf x := choose (p x). have xfp: forall x, inc x E -> (inc (xf x) F /\ inc x (Vg y (xf x))). move=> x xE; apply: (choose_pr (p:=p x)). 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 /functionsP; rewrite /x;hnf;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. have [vF tv]:= (xfp _ uE). 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 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: natp n -> cardinal E = n -> finite_int_fam a -> (csum a) ^c n = csumb (graphs_sum_eq (domain a) n) (fun p => (cardinal (partitions_pi p E)) *c (cprodb (domain a) (fun i=> ((Vg a i) ^c (Vg p i))))). Proof. move=> nN cEn fifa. set F:=csum a; set I := domain a. have sN:= (finite_sum_finite fifa). have cF: csum a = cardinal F by symmetry; apply: card_nat. have [pF] := (number_of_partitions1 fifa cF). move /partitions_piP => pipF. rewrite - {1} cEn cpowcr. pose g f i := (Vfi 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 /functionsP [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 =>//. have prop0F:= (pip_prop0 pipF). have [da cVa [fga duja uea]] := pipF. have sfa: forall f, inc f (functions E F) -> unionb (Lg I (g f)) = E. move=> f fs; move: (fs) => /functionsP [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]. hnf 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; hnf; bw;split => //. move => i iF; bw. hnf; 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 _ nN); rewrite /f1. rewrite - cEn -(sfa _ fs);split => //; bw; last first. hnf;bw; move => i itf; bw; fprops. fprops. apply /card_eqP;apply: equipotent_disjointU;fprops. split;fprops; rewrite /disjointU_fam; bw. by move=> i itf; bw; apply/card_eqP; rewrite cardinal_indexed double_cardinal. 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. hnf; 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 _. apply: (EqT (Eq_indexed2 aux p)); apply:(@EqT (product X Y)). rewrite /aux cprod2_pr1/cprod; set t:= product _ _. apply: (EqT (cardinal_pr t)). rewrite /t; clear t; apply: Eq_setX; fprops. rewrite /cprodb /cprod. set t:= productb _; apply: (EqT (cardinal_pr t)). rewrite /t; clear t; apply: Eq_setXb; hnf;bw;split;fprops. move=> i iI; bw; fprops. apply /card_eqP;rewrite - (cVa _ iI) cpowcl card_card; fprops. clear aux. set (Z:= (Zo (functions E F) (fun f => 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. have [bVf sVf tW] := (W1 _ _ fZ iI). move: fZ=> /Zo_P [feF f1f]. have g1P := (g_propP _ _ feF iI). move: feF => /functionsP [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 => //; first by rewrite tf; apply: prop0F; ue. by move=> t /(Vf_image_P ff sgi) [u /g1P [uE pr] ->]. have fr:= (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 => i iV; bw. move: (W3 _ _ fZ iV)(W1 _ _ fZ iV) => [p1 p2 p3][p4 p5 p6]. rewrite /WJ; apply /functionsP. split => //;aw; [ fct_tac | rewrite /restriction2; aw]. apply:EqS. exists (Lf (fun f =>(J (f2 f) (f3 f))) Z (X \times Y)). hnf;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_S usf. move: (uZ)(vZ) => /Zo_P [] /functionsP [fu su tu] f1u /Zo_P [] /functionsP [fv sv tv] f1v. apply: function_exten =>//; try ue. rewrite su -(sfa _ usf); move=> x /setUb_P; bw; move => [i iI]; bw => xgui. move: (f_equal (Vg ^~i) sf3); rewrite /f3; 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; last by 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 _ nN): (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 /functionsP => [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. hnf;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 /functionsP. 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 /functionsP => [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. have Wp':= (gp1 _ _ jI xVj). hnf 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; [ 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 => /functionsP [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. rewrite corresp_s => x xs. have fW: function (WK i) by fct_tac. have p1:inc (Vf (WK i)x ) (target (WK i)) by Wtac. move: (p1); rewrite tW => p11. rewrite compf_V //restriction2_V //. move: (proj33 (alaw _ iI)); rewrite -tW => p3;rewrite (p3 _ p1) /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))). by split;fprops;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: natp n -> csumb (Nintc n) (binom n) = \2c ^c n. Proof. move=> nN; symmetry. have cnn:=(card_nat nN). rewrite -(cardinal_set2 C0_ne_C1) -/C2 - (sum_of_gen_binom C2 nN cnn). set f:= fun m => (variantLc m (n -c m)). rewrite(@csum_Cn2 _ _ (Nintc n) f). apply: csumb_exten => x xi;bw. by rewrite (number_of_partitions_p4 nN (@Nint_S \0c n _ xi) cnn). split => //. + move=> m /Nintc_i mn; move: (cdiff_pr mn) => e1. rewrite /f;apply /(setof_sume_auxP _ nN);split => //;bw; fprops. hnf; bw => i itp; try_lvariant itp; [ exact:proj31 mn | fprops ]. + rewrite /f;move=> u v ui vi s; move: (f_equal (Vg ^~C0) s); bw. + move=> y / (setof_sume_auxP _ nN) [dy sy fgy alc]. rewrite /cardinal_fam /allf dy in alc. move: (alc _ inc_C0_C2) (alc _ inc_C1_C2) => ca cb. have abn: (Vg y C0) +c (Vg y C1) = n. rewrite - sy; apply: csum2_pr. exists C0, C1; rewrite dy;split;fprops. move: (nN); rewrite -abn => nN'. move: (Nat_in_suml ca nN')(Nat_in_sumr cb nN') => aN bN. move: (csum_M0le (Vg y C1) ca); rewrite abn => an. exists (Vg y C0); first by apply /NintcP. rewrite /f;apply: fgraph_exten; bw; fprops. rewrite dy;move=> x xtp; try_lvariant xtp. rewrite -abn csumC cdiff_pr1 //. Qed. Lemma sum_of_binomial n: natp n -> csumb (Nintc n) (binom n) = \2c ^c n. Proof. move=> nN. rewrite - card_setP. set (idx:= Nintc 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; apply: Eq_indexed. 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 /(NintcP nN); move: (tp) => /setP_P /sub_smaller. by rewrite (card_nat nN). by ex_tac; bw; apply: Zo_i. move /card_eqP ->. apply: csum_pr3; fprops; rewrite /X;bw => i ix; bw. move: (@Nint_S \0c n _ ix) => iN. rewrite - subsets_with_p_elements_pr0 //. exact: (card_nat (NS_binom nN iN)). Qed. Lemma sum_of_binomial2 a b n: natp n -> csumb (Nintc n) (fun p => (binom n p) *c (a ^c p) *c (b ^c (n -c p))) = (a +c b) ^c n. Proof. move: n; apply: Nat_induction. rewrite cpowx0 Nint_cc00 csum_trivial3 cdiff_nn binom00. by rewrite ! cpowx0 (cprod1r CS1) (cprod1r CS1) (card_card CS1). move=> n nN. rewrite {1} /csumb; set fn := Lg _ _ => hrec. set X:=((a +c b) ^c n). set I := (Nintc n). have IN:sub I Nat by apply: Nint_S. pose q0 i := (a ^c i) *c (b ^c (n -c i)). pose q1 i := (a ^c (csucc i)) *c (b ^c ((csucc n) -c (csucc i))). pose f1 i := (binom n (csucc 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 ((csucc n) -c i)). have P1: csum (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 (cdiff_pr6 nN (IN _ xi)). by rewrite (cpow_succ _ (IN _ xi))- !cprodA (cprodC a). symmetry;rewrite /X -hrec (cprod2Dn a fn) /fn; bw; apply: csumb_exten. move=> x xI /=; bw; rewrite cprodA cprodA - cprodA //. have P2: csum (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. move: (xi) => /(NintcP nN) ha. by rewrite (cdiffSn nN ha) (cpow_succ _ (NS_diff x nN)). symmetry;rewrite /X -hrec (cprod2Dn b fn) /fn Lg_domain;apply: csumb_exten. by move=> x xI /=; bw; rewrite - (cprodA (binom n x)). clear hrec fn. have snN:= (NS_succ nN). rewrite (NintcE snN) (fct_sum_rec1 _ snN). have a1: cardinalp (b ^c (csucc n)) by fprops. rewrite (binomSn0 nN) cpowx0 (cdiff_n0 snN) (cprod1l CS1) (cprod1l a1). set ffn:= fun i => _. move: (sum_of_sums f1 f2 I); rewrite /csumb - {1}(NintcE nN). have -> :Lg I (fun i => (f1 i) +c (f2 i)) = (Lg I ffn). apply: Lg_exten => i iI. by rewrite /ffn -/(q1 i) /f1 /f2 (binomSnSm nN (IN _ iI)) - cprodA cprodDr. have <-: (g1 \0c) = (b ^c (csucc n)). rewrite /g1 cpowx0 (cdiff_n0 snN) (binom0 nN). by rewrite (cprod1l CS1)(cprod1l (CS_pow b (csucc n))). move => <-; rewrite P1 (csumC _ (a *c X)) - csumA. have p1: Lg I (fun i=> g1 (csucc i)) = (Lg I f1). apply: Lg_exten; move=> u uI; rewrite /f1 /g1 - cprodA //. move:(fct_sum_rec1 g1 snN). rewrite /csumb - (NintcE snN) - {2}(NintcE nN) -/I p1 => <-. have ->: csum (Lg (Nintc (csucc n)) g1)= b *c X. have aux:= (cltS nN). rewrite -P2 /I (NintcE snN) (NintcE nN) -/(csumb _ _). rewrite (induction_on_sum g1 snN) {2}/g1 (binom_bad nN snN aux). rewrite 2! cprod0l csum0r //; apply: CS_csum. rewrite - cprodDr cprodC (Nsucc_rw nN) cpow_sum2 cpowx1; fprops. Qed. (* Number of increasing functions *) 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 (Imf f)). Proof. move=> tor si. have mor:= (total_order_increasing_morphism tor si). have injf:= (order_morphism_fi mor). have bj := (restriction_to_image_fb injf). split => //;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 [] /functionsP [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. move: (proj1 tor) => or. apply: lf_bijective =>//. move=> u v /Zo_P [] /functionsP [fu su tu] siu /Zo_P [] /functionsP [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) => 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: (worder_prop wor p1 p2)=> [y 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 /p4 yt: inc t Z by apply: Zo_i =>//; order_tac. 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)) by 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' := proj1 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''; apply:EqS. 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 | by rewrite /canonical_injection - sr''; aw]. 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=>//. have [[fcg ing] sug] := bg. have xsr: inc x src. rewrite /src; apply: Zo_i => //; first by apply /functionsP. split => // a b [ab nab]. move: (arg1_sr ab) (arg2_sr ab); rewrite - sg => asx bsx. 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 => range (graph z)) src trg); split => //; aw. rewrite /trg. symmetry;set n := cardinal _; set p := cardinal _. have nN: natp n by apply /NatP; apply: fsr'. have pN: natp p by apply /NatP; apply: fsr. have cE: cardinal (substrate r') = n by []. by rewrite (subsets_with_p_elements_pr nN pN cE). Qed. Lemma increasing_prop0 p f r: natp p -> order r -> (forall i, i <=c p -> inc (f i) (substrate r)) -> (forall n, n gle r (f n) (f (csucc n))) -> (forall i j, i <=c j -> j <=c p -> gle r (f i) (f j)). Proof. move=> pN or als hyp i j ij jp. have jN:= NS_le_nat jp pN. have iN:= NS_le_nat ij jN. move:(cdiff_pr ij) (NS_diff i jN). set k := (j -c i); move=> ikj kN; rewrite -ikj. move: {1 2 4} k (kN) (cleR (CS_nat kN)). apply: Nat_induction. move => _;rewrite (Nsum0r iN); order_tac;apply: als (cleT ij jp). move => n nN prn h. have le3:= (clt_leT (cltS nN) h). have le4: (i +c n) le4. exact:clt_leT le4 jp. move: (hyp _ le4); rewrite - (csum_nS _ nN). move: (prn (cleT (cleS nN) h)) => r1 r2; order_tac. Qed. Lemma strict_increasing_prop0 p f r: natp p -> order r -> (forall n, n glt r (f n) (f (csucc n))) -> (forall i j, i j <=c p -> glt r (f i) (f j)). Proof. move=> pN or hyp i j ij jp. have jN:= NS_le_nat jp pN. have iN:= NS_lt_nat ij jN. have ip:= clt_leT ij jp. move /(cleSltP iN): ij => ij. have siN: natp (csucc i) by fprops. move: (cdiff_pr ij)(NS_diff (csucc i) jN); set k := (j -c (csucc i)). move => ikj kN; rewrite - ikj. move: {1 2 4} k (kN) (cleR (CS_nat kN)). apply: Nat_induction; first by move=> _; rewrite (Nsum0r siN); apply: hyp. move => n nN prn h. rewrite (csum_Sn _ iN) (csum_nS _ nN). have ltkn: n ha. exact:clt_leT ha jp. move: (hyp _ mp) (prn (proj1 ltkn)); rewrite (csum_Sn _ iN) => sa sb;order_tac. Qed. Lemma increasing_prop p f r: natp p -> function f -> source f = (csucc p) -> order r -> substrate r = target f -> (forall n, n gle r (Vf f n) (Vf f (csucc n))) -> increasing_fun f (Nint_cco \0c p) r. Proof. move=> pN ff sf or sr sge. have zN: natp \0c by fprops. have bi:Nintc p = source f by rewrite sf -(NintE (NS_succ pN)) ; apply: Nint_co_cc. have [pa pb] := (Ninto_wor \0c p). have [sor _ ] := (worder_total pa). split => //; first by rewrite pb. move=> x y /Ninto_gleP [xs ys lxy]. move: ys => /(NintcP pN) yp. have aux: (forall i, i <=c p -> inc (Vf f i) (substrate r)). by move=> i ip; Wtac; rewrite sf; apply /NleP. exact: (increasing_prop0 pN or aux sge lxy yp). Qed. Lemma strict_increasing_prop p f r: natp p -> function f -> source f = (csucc p) -> order r -> substrate r = target f -> (forall n, n glt r (Vf f n) (Vf f (csucc n))) -> (injection f /\ strict_increasing_fun f (Nint_cco \0c p) r). Proof. move => pN ff sf or sr prop. have zN: natp \0c by fprops. have bi:Nintc p = source f by rewrite sf -(NintE (NS_succ pN)) ; apply: Nint_co_cc. have [pa pb] := (Ninto_wor \0c p). have tor := (worder_total pa). have sic: (strict_increasing_fun f (Nint_cco \0c p) r). split; [ by case:tor | done | by rewrite pb | ]. move=> x y [] /Ninto_gleP [xs ys lxy] xne. move: ys => /(NintcP pN) yp. have ltxy: x //. move: (total_order_increasing_morphism tor sic). apply: order_morphism_fi. Qed. Lemma strict_increasing_prop1 f p: natp p -> (forall i, i natp (f i)) -> (forall i j, i j (f i) (forall i, i i <=c (f i)). Proof. move=> pN ali hi i lip. have iN:= NS_lt_nat lip pN. move: i iN lip; apply: Nat_induction. by move=> /ali /CS_nat h;apply: czero_least. move=> n nN pn aux. have le2:=(cltS nN). have le3:=(hi _ _ le2 aux). have le4:= (pn (clt_ltT le2 aux)). apply /cleSlt0P; [ fprops | fprops | exact:cle_ltT le4 le3]. Qed. Lemma increasing_prop1 p f: natp p -> (forall i, i <=c p -> natp (f i)) -> (forall n, n (f n) <=c (f (csucc n))) -> (forall i j, i <=c j -> j <=c p -> (f i) <=c (f j)). Proof. move => pN p1 p2 i j ij jp. have [[or _] sr]:= (Nat_order_wor). set r := Nat_order. have q1: (forall i, i <=c p -> inc (f i) (substrate r)) by rewrite sr. have q2:(forall n, n gle r (f n) (f (csucc n))). move=> n np; apply/ Nat_order_leP; split;fprops. by apply: p1; move: np => [np _]. apply: p1; apply /cleSlt0P => //; fprops. by move: np=> [[cn _] _]. move: (increasing_prop0 pN or q1 q2 ij jp). by case /Nat_order_leP. Qed. Lemma strict_increasing_prop2 f p: natp p -> (forall i, i natp (f i)) -> (forall i j, i j (f i) (forall i j, i <=c j -> j ((f i) -c i) <=c ((f j) -c j)). Proof. move=> pN ali hyp. case: (equal_or_not p \0c). move => -> i j ij jp; case: (clt0 jp). move=> pnz. have [qN ps] := (cpred_pr pN pnz). set q := cpred p. have fq: finite_c (cpred p) by fprops. pose g i := (f i) -c i. have q1: (forall i : Set, i <=c q -> natp (g i)). by move=> i ip; apply: NS_diff; apply: ali; rewrite ps;apply/(cltSleP qN). have q2:forall n, n (g n) <=c (g (csucc n)). move=> n np. have nN:= (NS_lt_nat np qN). have hy:=(strict_increasing_prop1 pN ali hyp). have p1: (csucc n) qp1 qp2. move: (ali _ p1)(ali _ p2) => s1 s2. apply/(cltSleP (NS_diff(csucc n) s1)); rewrite - (csucc_diff s1 nN qp1). apply: (cdiff_pr7 qp2 (hyp _ _ (cltS nN) p1) s1). move=> i j ij jp. apply: (increasing_prop1 qN q1 q2 ij). by move: jp; rewrite {1} ps; move /(cltSleP qN). Qed. Lemma strict_increasing_prop3 f p n: natp p -> natp n -> (forall i, i natp (f i)) -> (forall i j, i j (f i) (forall i, i (f i) (forall i, i ((f i) -c i) <=c n). Proof. move=> pN nN ali fi fb. move=> i ip. case: (equal_or_not p \0c) => h. rewrite h in ip;case: (clt0 ip). have [qN psq] := (cpred_pr pN h). move:ip; rewrite psq; move /(cltSleP qN)=> iq. have qp: ((cpred p) /(cltSleP sN). by move/(csum_le2l qN (NS_diff (cpred p) (ali _ qp)) nN). Qed. Lemma cardinal_set_of_increasing_functions3 n p: natp n -> natp p -> cardinal (functions_incr (Nint_co p) (Nint_cco \0c n)) = binom (n +c p) p. Proof. move=> nN pN. set r := (Nint_co p). set r' := (Nint_cco \0c n). set (E1:=Nint p). have s1: E1= substrate r by rewrite /E1 (proj2 (Nintco_wor _)). set E2:=Nintc n. have s2: (E2= substrate r') by rewrite /E2 (proj2 (Ninto_wor _ _)); fprops. set np := n +c p. have npN: natp np by rewrite /np; fprops. set (r'':= Nint_co np). set (E3:=Nint np). have s3: E3= substrate r'' by rewrite /E3 - (proj2 (Nintco_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 [] /functionsP pa pd. by move => [pa pb]; apply: Zo_i => //; apply /functionsP. have HQ2P: forall x, inc x Q2 <-> P2 x. move=> x; rewrite /Q2 /P2 s1 s3; split. by move => /Zo_P [] /functionsP pa pd. by move => [pa pd]; apply: Zo_i => //; apply /functionsP. have E1N :sub E1 Nat by rewrite /E1; apply: Nint_S1. have E2N :sub E2 Nat by rewrite /E2; apply: Nint_S. have E3N :sub E3 Nat by rewrite /E3; apply: Nint_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 natp (Vf f i)), (forall i j, i j (Vf f i) (i <=c (Vf f i)))]. move=> f /HQ2P [[ff sf tf] sif]. have aux: (forall i, i natp (Vf f i)). by move=> i ilp; apply: E3N =>//; Wtac; rewrite sf /E1; apply/NintP. have aux2:(forall i j, i j (Vf f i) i j ij jp. move: (ij) => [ij1 _]; have lip:= (clt_ltT ij jp). have isf: (inc i (source f)) by rewrite sf /E1;apply/NintP. have jsf: (inc j (source f)) by rewrite sf /E1;apply/NintP. have lij: glt r i j. move: ij => [ij nij]; rewrite /r; split=>//. apply / Nintco_gleP => //. move: sif => [ _ _ _ h]; move: (h _ _ lij) => [lVf nW]. by split =>//; move: lVf; move /(Nintco_gleP npN) => []. split => //. move=> i /(NintP pN) h. by apply: (strict_increasing_prop1 pN 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 pN p1 p2) => p4. have p5: (forall i, i (Vf f i) i ip. move: fQ2 => / HQ2P [[ff sf tf] vf]. have : (inc (Vf f i) E3). by rewrite -tf; Wtac; rewrite sf;apply/ (NintP pN). by move /(NintP npN). move: (strict_increasing_prop3 pN nN p1 p2 p5) => p6. by move=> i /(NintP pN) => ip; apply /(NintcP nN);apply: p6. have Hi1:forall f, inc f Q2 -> inc (subi f) (functions E1 E2). move=> f fQ2;apply /functionsP; rewrite /subi; hnf;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: (Nintco_wor p) => [[or _] _]. move: (Ninto_wor \0c n) => [[or' _] _]. rewrite /subi;hnf; aw; split => //; first (split; aw). by apply: lf_function. move=> x y xy. move: (arg1_sr xy)(arg2_sr xy); rewrite - s1 => xsf ysf. have [p1 p2 p3] := (Hi0 _ fQ2). have p4 := (strict_increasing_prop2 pN p1 p2). have yp: y /(Nintco_gleP pN) []. by move: (p4 _ _ xy' yp); aw => xx; apply /Ninto_gleP; split => //;apply: ta. set (G:= Lf (fun f=> subi f) Q2 Q1). have Hi4:function G by rewrite / G; apply: lf_function. pose addi 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 /functionsP [ff sf tf] t tE1. have: (inc (Vf f t) E2) by Wtac. move: tE1 => /(NintP pN) p1 /(NintcP nN) p2. apply /(NintP npN); apply: csum_Mlelt =>//. have pa2: (forall f, inc f (functions E1 E2) -> inc (addi f) (functions E1 E3)). move=> f fE; rewrite /addi; apply /functionsP;hnf;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) => /functionsP [fa sa ta]; split => //. hnf; rewrite /function_prop sa ta; split => //. by move: (Nintco_wor p) => [[or _] _]. by move: (Nintco_wor np) => [[or _] _]. move=> x y [xy nxy]. move: (arg1_sr xy)(arg2_sr xy); rewrite - s1 => xe1 ye1. have ta1 := (pa _ fe1e2). rewrite /addi lf_V // lf_V //. move: incf => [_ _ _ h]; move: (h _ _ xy); rewrite /r'/r'' /glt. have zN: natp \0c by fprops. move /Ninto_gleP => [p1 p2 p3]. have ltxy: x //; move: xy; move /(Nintco_gleP pN) => []. move /(NintcP nN):p1 => p1. move /(NintcP nN):p2 => p2. move /(NintP pN): (ye1) => p6. have p7:= (csum_Mlelt nN p2 p6). have [p4 p5]:= (csum_Mlelt (NS_le_nat p2 nN) p3 ltxy). by split => //; apply /(Nintco_gleP npN). 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: E1N. apply: E2N;rewrite -tx//; Wtac. apply: pa; apply /functionsP;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. - have ta3:= (Hi3 _ xQ2). have ta2:=(pa _ (Hi1 _ xQ2)). 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 (Nint_co np))) = np. by rewrite (proj2 (Nintco_wor _)) card_Nint. have r2: (cardinal (substrate (Nint_co p))) = p. by rewrite (proj2 (Nintco_wor _)) card_Nint. rewrite /Q2 /r/r'' cardinal_set_of_increasing_functions /finite_set. - rewrite r1 r2 //. - apply: worder_total; apply: (proj1 (Nintco_wor _)). - apply: worder_total; apply: (proj1 (Nintco_wor _)). - by rewrite r2; fprops. - by rewrite r1; fprops. Qed. Lemma cardinal_set_of_increasing_functions4 r r' (n := cardinal (substrate r')) (p := cardinal (substrate r)): total_order r -> total_order r' -> finite_set (substrate r) -> finite_set (substrate r') -> cardinal (functions_incr r r') = binom ((n +c p) -c \1c) p. Proof. move=> tor tor' fsr fsr'. have nN: natp n by move: fsr' => /NatP. have pN: natp p by move: fsr => /NatP. have or:= proj1 tor. have or':= proj1 tor'. case: (equal_or_not n \0c) => nz. have qe := (card_nonempty nz). rewrite nz (Nsum0l pN) /functions_incr qe. case: (equal_or_not p \0c) => pz. have sr := (card_nonempty pz). rewrite pz (cdiff_wrong cle_01) binom00 sr. set qq:=Zo _ _. move:empty_function_function => xx. have efq: inc empty_function qq. apply : Zo_i; first by apply /functionsP. by hnf; rewrite qe sr; split => // a b /arg1_sr;rewrite sr => /in_set0. have: qq = singleton empty_function. apply:set1_pr => // z /Zo_S zq;exact:(fun_set_small_source zq (Zo_S efq)). by move => ->; rewrite cardinal_set1. move: (cpred_pr pN pz) => [ppN sp]. rewrite - (cpred_pr4 (CS_nat pN)) (binom_bad ppN pN (cpred_lt pN pz)). set qq:=Zo _ _ ; case: (emptyset_dichot qq). by move=> ->; apply: cardinal_set0. move=> [t /Zo_S /functionsP [ft st tt]]. case: (emptyset_dichot (substrate r)) => h. by case: pz; rewrite /p h cardinal_set0. by move: h=> [x]; rewrite - st; move/ (Vf_target ft); rewrite tt=> /in_set0. move: (cpred_pr nN nz) => [pnN sn]. rewrite (cdiffA2 nN pN (cge1 (CS_nat nN) nz)) - (cpred_pr4 (CS_nat nN)). have [f [isf _]] :=(finite_ordered_interval1 tor fsr). have [g [isg _]] := (finite_ordered_interval1 tor' fsr'). have isif:= (inverse_order_is isf). have isig:= (inverse_order_is isg). rewrite- (cardinal_set_of_increasing_functions3 pnN pN). rewrite/Nint_cco -/(Nintcc _ _) -/(Nintc _)(Nint_co_cc pnN) - sn -/(Nint_co n). 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:= (proj1 b_g). have fg:function g by fct_tac. have s_f: (surjection f') by move : isif=> [_ _ [[_ ok] _ _]]. have fif:= (proj1 s_f). have sig:= (order_isomorphism_increasing isg). have siif := (order_isomorphism_increasing isif). have [_ _ [_ sg tg] _] := sig. have [_ _ [_ soif tf'] _] := siif. 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/Zo_S: (wQ) => /functionsP [fw sw tw]; rewrite c3f_V //; ue. 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; hnf;aw;split => //; apply: lf_bijective => //. move=> u v u1 v1;rewrite -(ffc3 _ u1) -(ffc3 _ v1). by move: (c3f_fi s_f i_g) => [_]; apply;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. have sig' := (order_isomorphism_increasing isig). have siif' := (order_isomorphism_increasing isf). move: (siif') => [_ _ [qa' qb' qc'] _]. have soig' :(substrate (Nint_co n) = source g') by rewrite qb. set x := (g' \co y) \co f. have xQ1: inc x Q1. move: yQ2=> /Zo_P [zs iz]. move: (increasing_compose3 siif' iz sig') => [p1 p2 p3]. by apply: Zo_i => //; rewrite - qc -qb'. ex_tac. move: yQ2 => /Zo_P [] /functionsP [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: natp n -> binom (csucc n) \2c = (n *c (csucc n)) %/c \2c. Proof. move=> nN;rewrite binom2//. Qed. Lemma binom_2plus0 n: natp n -> binom (csucc n) \2c = (binom n \2c) +c n. Proof. move=> nN. by rewrite - succ_one (binomSnSm nN NS1) (binom1 nN). Qed. Lemma cardinal_pairs_lt n: natp n -> cardinal (Zo (coarse Nat) (fun z => [/\ \1c <=c (P z), (P z) nN; rewrite /coarse. set (E:= Nint1c n). set T:=Zo _ _. move: NS1 NS2 => oN tN. case: (p_or_not_p (\2c <=c n)); last first. case: (cleT_el CS2 (CS_nat nN)). by move=> h h'; contradiction. move=> h _; rewrite binom_bad //. case: (emptyset_dichot T); first by move=> ->; rewrite cardinal_set0. move=> [p /Zo_P [a1 [a2 a3 a4]]];move: a3. by case: (clt2 (cle_ltT a4 h)) => ->; [move /clt0 | move => /(cleNgt a2) ]. move=> le2n. have cE: cardinal E = n by rewrite card_Nint1c. rewrite (subsets_with_p_elements_pr nN tN 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]]. move: (cleT lepq leqn) (cleT le1p lepq) => a1 a2. have pE: inc (P z) E by apply /Nint_ccP1. have qE: inc (Q z) E by apply /Nint_ccP1. 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 =>//. by move: lt1;rewrite e1 e2; move => [/(cltNge lt2)]. move => y /Zo_P [] /setP_P yE cy2. have [a [b [p1 p2 aN bN]]]: exists a, exists b, [/\ a [a [b [ab ->]]] yN. move: (yN _ (set2_1 a b))(yN _ (set2_2 a b)) => aN bN. case: (NleT_el aN bN); [ by exists a, b | by rewrite set2_C ;exists b, a]. exists (J a b); aw => //. apply: Zo_i; aw; first fprops. have: inc a E by apply: yE; rewrite -p2; fprops. have: inc b E by apply: yE; rewrite -p2; fprops. by move /(Nint_ccP1 NS1 nN) => [_ pb] /(Nint_ccP1 NS1 nN) [pc _]. Qed. Lemma cardinal_pairs_le n: natp n -> cardinal(Zo (coarse Nat) (fun z=> [/\ \1c <=c (P z), (P z) <=c (Q z) & (Q z) <=c n])) = (binom (csucc n) \2c). Proof. move=> nN. rewrite (binom_2plus0 nN). 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:= Nintcc \1c n). have ->: n = cardinal T by rewrite card_Nint1c. apply /card_eqP. exists (Lf P (E1 -s E2) T); hnf;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 /(Nint_ccP1 NS1 nN); 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 => /(Nint_ccP1 NS1 nN) [l1y lyn]. have yN:= NS_le_nat lyn nN. exists (J y y); aw => //; apply /setC_P; split. apply: Zo_i; [ fprops | aw;split;fprops]. move /Zo_hi => [_ [_ bad] _]; case: bad; aw. Qed. Lemma sum_of_i n: natp n -> csumb n id = binom n \2c. Proof. move: n; apply: Nat_induction. by rewrite (binom_bad NS0 NS2 clt_02) csum_trivial0. move=> n nN hr;rewrite induction_on_sum // hr binom_2plus0 //. Qed. Lemma fct_sum_const1 f n m: natp n -> (forall i, i f i = m) -> csumb n f = n *c m. Proof. move=> nN p. transitivity (csum (cst_graph n m)). by apply: csumb_exten => t /(NltP nN) /p. by rewrite csum_of_same cprodC - cprod2cl. Qed. Lemma sum_of_i3 n: natp n -> csumb n id = binom n \2c. Proof. move=> nN. move: clt_02 => lt20. case: (equal_or_not n \0c) => nz. by rewrite nz (binom_bad NS0 NS2 clt_02) csum_trivial0. move: (cpred_pr nN nz) => [pN nsp]. rewrite nsp binom2 //. set p := cpred n in pN nsp |- *. rewrite /csumb; set sn:= csum _ . set aux:= (p *c (csucc p)). suff eq: (sn +c sn = aux). have cn: cardinalp sn by rewrite /sn; fprops. have aN: natp aux by rewrite /aux; fprops. have sN: natp sn. rewrite - eq in aN; apply: (Nat_in_sumr cn aN). by rewrite -eq - two_times_n; symmetry; apply: even_half. move: (sum_of_sums (fun i => i) (fun i=> (p -c i)) (csucc p)). rewrite nsp in nN. have fim: (forall i : Set, i (fun i : Set => i +c (p -ci)) i = p). move=> i /(cltSleP pN) => ilp. by apply: cdiff_pr. rewrite (fct_sum_const1 nN fim). rewrite cprodC /aux; move => <-; apply: f_equal. rewrite /sn - /(csumb _ _) fct_sum_rev //. Qed. Lemma sum_of_i2 n: natp n -> csumb (Nintcc \1c n) id = (binom (csucc n) \2c). Proof. move => nN. rewrite -(sum_of_i3 (NS_succ nN)) -(NintE (NS_succ nN)) - (Nint_co_cc nN). move: (sum_of_i3 (NS_succ nN)). move: (Nint_pr5 nN) => [<- pb]. rewrite csumA_setU1 //; aw; rewrite /csumb ; fprops. Qed. Lemma sum_of_i2bis n: natp n -> csumb (Nintcc \1c n) id = (binom (csucc n) \2c). Proof. move => nN. rewrite - cardinal_pairs_le //. set (E:= Nintcc card_one n). 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 have h:= (cleT le1 le2); apply /(Nint_ccP1 NS1 nN). 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 => Nintcc card_one i)). rewrite /f /disjointU_fam; bw; apply: Lg_exten. move=> x xE; move: (xE)=> /(Nint_ccP1 NS1 nN) [ox xn]. have xN:= NS_le_nat xn nN. bw; set_extens t. move => /Zo_P [] /Zo_P [] /setX_P [pt _ qN] [oP pq _] qt. apply /indexed_P;split => //; apply /(Nint_ccP1 NS1 xN); split => //; ue. move /indexed_P => [pt] /(Nint_ccP1 NS1 xN) [pa pb] pc. apply: Zo_i => //; apply /Zo_P; rewrite pc. split => //; apply /setX_P; rewrite pc. split => //;apply:NS_le_nat pb xN. have ->: X = disjointU (Lg E (fun i => Nintcc \1c i)). by rewrite p1 p2 /disjointU. apply /card_eqP; apply: equipotent_disjointU1. split;fprops; bw => i iE; bw. have iN:= (Nint_S iE). apply /card_eqP; rewrite card_Nint1c // card_card; fprops. Qed. (** number of monomials *) Lemma sof_sum_eq_equi F n: natp n -> (functions_sum_eq F n) \Eq (graphs_sum_eq F n). Proof. move=> nN. exists (Lf graph (functions_sum_eq F n) (graphs_sum_eq F n)). hnf;aw; split => //; apply: lf_bijective. move => t ts; apply /funI_P; ex_tac. move=> u v /Zo_S /functionsP [fu su tu] /Zo_S /functionsP [fv sv tv] ge. apply: function_exten3 =>//; try ue. by move=> y /funI_P. Qed. Lemma sof_sum_le_equi F n: natp n -> (functions_sum_le F n) \Eq (graphs_sum_le F n). Proof. move=> nN. exists (Lf graph (functions_sum_le F n) (graphs_sum_le F n)). hnf;aw; split => //;apply: lf_bijective. move => t ts; apply /funI_P; ex_tac. move=> u v /Zo_S /functionsP [fu su tu] /Zo_S /functionsP [fv sv tv] ge. apply: function_exten3 =>//; try ue. by move=> y /funI_P. Qed. Lemma set_of_functions_sum0 f: (forall a, natp a -> f \0c a = \1c) -> (forall a, natp a -> f a \0c = \1c) -> (forall a b, natp a -> natp b -> f (csucc a) (csucc b) = (f (csucc a) b) +c (f a (csucc b))) -> forall a b, natp a -> natp b -> f a b = (binom (a +c b) a). Proof. move=> p2 p3 p4. move=> a b aN bN; move: a aN b bN. apply: Nat_induction. move=> b bN; rewrite p2; aw; [ rewrite binom0 =>// | fprops]. move=> n nN fnb b bN. rewrite (csum_Sn _ nN). move: b bN; apply: Nat_induction. have snN: natp (csucc n) by fprops. by rewrite (Nsum0r nN) (binom_nn snN) (p3 _ snN). move=> c cN fsn. have sc: natp (csucc c) by fprops. rewrite (p4 _ _ nN cN) (fnb _ sc) fsn. by rewrite - (csum_nS _ cN) (binomSnSm (NS_sum nN sc) nN). Qed. Lemma set_of_functions_sum1 E x n: natp n -> ~ (inc x E) -> (graphs_sum_le E n) \Eq (graphs_sum_eq (E +s1 x) n). Proof. move=> nN nxE. set (K:= Nintc n). set (f:= fun z=> z +s1 (J x (n -c (csum z)))). exists (Lf f (graphs_sum_le E n) (graphs_sum_eq (E +s1 x) n)). hnf;aw; split => //; apply: lf_bijective. + move => z /(setof_suml_auxP _ nN) [dz lez fgz alc]. apply /(setof_sume_auxP _ nN). 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 (csum z)) by 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; fprops. split => //. rewrite - (Lg_recovers p0) -p1 -/(csumb _ _) csumA_setU1 // -dz /csumb. 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:cdiff_pr. + move => u v /(setof_suml_auxP _ nN) [fu su tu _]. move /(setof_suml_auxP _ nN) => [fv sv tv _]. apply: extension_injective => //; ue. + move=> y /(setof_sume_auxP _ nN) [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 = csum (Lg E (Vg y)) +c Vg y x. rewrite - sy -{1} (Lg_recovers ty) -/(csumb (domain y) _). by rewrite fy (csumA_setU1 _ nxE). have pd: Vg y x = n -c csum (Lg E (Vg y)). rewrite pc in nN; rewrite pc csumC cdiff_pr1 //. apply: (Nat_in_sumr _ nN); apply: suy; rewrite fy; fprops. apply: (Nat_in_suml _ nN); fprops. exists (Lg E (Vg y)). apply /(setof_suml_auxP _ nN); 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: natp n -> cardinal(graphs_sum_le E (csucc n)) = (cardinal (graphs_sum_eq E (csucc n))) +c (cardinal (graphs_sum_le E n)). Proof. move => nN. have snN: natp (csucc n) by fprops. set A:= (graphs_sum_eq E (csucc n)). set B:= (graphs_sum_le E (csucc n)). set C:= (graphs_sum_le E n). have di: disjoint A C. apply: disjoint_pr. move=> u; move /(setof_sume_auxP _ snN) => [_ pb _ _]. move /(setof_suml_auxP _ nN) => [_]. by rewrite pb => qa; move: (cleNgt qa (cltS nN)). suff: B = A \cup C by move => ->; rewrite (csum2_pr5 di) csum2cl csum2cr. set_extens t. move /(setof_suml_auxP _ snN) => [pa pb pc1 pc2]; apply /setU2_P. case: (equal_or_not (csum t) (csucc n)) => h. left; apply /(setof_sume_auxP _ snN); split => //. right; apply /(setof_suml_auxP _ nN); split => //. by apply /(cltSleP nN); split. case /setU2_P. move /(setof_sume_auxP _ snN) => [pa pb pc1 pc2]. apply /(setof_suml_auxP _ snN);split => //; rewrite pb; fprops. move /(setof_suml_auxP _ nN) => [pa pb pc1 pc2]. apply /(setof_suml_auxP _ snN);split => //. apply:cleT pb (cleS nN). Qed. Lemma set_of_functions_sum3 E: cardinal (graphs_sum_le E \0c) = \1c. Proof. have zb:= NS0. set w:= graphs_sum_le _ _. suff ->: (w = singleton (Lg E (fun _ =>\0c))) by apply: cardinal_set1. apply: set1_pr. apply /(setof_suml_auxP _ zb); bw;split; fprops. rewrite csum_of_same cprod0l; fprops. hnf; bw => t ti; bw; fprops. move => z zw. move: (zw); rewrite /w/graphs_sum_le. move /funI_P => [g] /Zo_S /functionsP [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. by move: (Vf_target qa zi); rewrite qc /Vf qd; move /(NintcP NS0) /cle0. Qed. Lemma set_of_functions_sum4 n: natp n -> cardinal (graphs_sum_le emptyset n) = \1c. Proof. move=> nN. suff: (graphs_sum_le emptyset n =singleton emptyset). by move=> ->;apply: cardinal_set1. apply: set1_pr. apply /(setof_suml_auxP _ nN);split; [bw | | fprops | ]. + rewrite csum_trivial; fprops; bw. + apply: fgraph_set0. + by move => t;rewrite domain_set0 => /in_set0. by move => z/ (setof_suml_auxP _ nN) [ /domain_set0_P g df _ _]. Qed. Lemma set_of_functions_sum_pr n h (intv:= fun h => (Nint h)) (sle:= fun n h => graphs_sum_le (intv h) n) (seq := fun n h => graphs_sum_eq (intv h) n) (A:= fun n h => cardinal (sle n h)) (B:= fun n h => cardinal (seq n h)): natp n -> natp h -> (A n h = B n (csucc h) /\ A n h = (binom (n +c h) n)). Proof. move=> nN hN. have AB: forall a b, natp a -> natp b -> A a b = B a (csucc b). move=> a b aN bN; rewrite /A /B /sle/seq; apply /card_eqP. move: (Nint_pr4 bN) => [p1 p2]. rewrite /intv -p1; apply: (set_of_functions_sum1 aN p2). split; first by apply: AB. have Hv: forall a b, natp a -> natp b -> A (csucc a) b = (B (csucc a) b) +c (A a b). move=> a b aN bN; rewrite /A/B /sle /seq. by rewrite - (set_of_functions_sum2 (intv b) aN). apply: set_of_functions_sum0. - move=> a aN; rewrite /A/sle; apply: set_of_functions_sum3. - move=> a aN;rewrite /A/sle. have ->: (intv \0c = emptyset). by rewrite /intv;apply: Nint_co00. apply: set_of_functions_sum4 =>//. - move=> a b aN bN. by rewrite (Hv _ _ aN (NS_succ bN)) -(AB _ _ (NS_succ aN) bN). - exact. - exact. Qed. Definition graphs_sum_le_int p n := graphs_sum_le (Nintc p) n. Definition functions_incr_int p n := (Zo (functions (Nintc p) (Nintc n)) (fun z => increasing_fun z (Nint_cco \0c p) (Nint_cco \0c n))). Lemma card_set_of_increasing_functions_int p n: natp p -> natp n -> cardinal (functions_incr_int p n) = binom (csucc (n +c p)) (csucc p). Proof. move=> pN nN. have spN:= NS_succ pN. rewrite -(csum_nS _ pN). rewrite - (cardinal_set_of_increasing_functions3 nN spN). rewrite /functions_incr_int /functions_incr. have zN:= NS0. rewrite (proj2 (Nintco_wor _)) (proj2 (Ninto_wor _ _)) - Nint_co_cc //. have-> //: (Nint_co (csucc p) = (Nint_cco \0c p)). move: (Nint_co_cc pN);rewrite /Nint_cco /Nintc /Nintcc => -> //. Qed. Lemma double_restrc f n: natp n -> restr (restr f (Nintc (csucc n))) (Nintc n) = restr f (Nintc n). Proof. move=> nN; have snN := NS_succ nN. rewrite double_restr // (NintcE nN) (NintcE snN) (succ_of_Nat snN). apply: sub_setU1. Qed. Lemma induction_on_sum3 f m: fgraph f -> natp m -> domain f = Nintc m -> (forall a, inc a (domain f) -> cardinalp (Vg f a)) -> (csum (restr f (Nintc \0c))= (Vg f \0c) /\ (forall n, n <=c m -> (csum (restr f (Nint n))) +c (Vg f n) = csum (restr f (Nint (csucc n))))). Proof. move=> fgf mN df alc. split. rewrite Nint_cc00 /restr -/(csumb _ _) csum_trivial3 card_card //. apply: alc; rewrite df NintcP; fprops. move=> n lenm. have nN:= NS_le_nat lenm mN. move: (Nint_pr4 nN) => [pa pb]. move: (csumA_setU1 (fun z => Vg f z) pb). by rewrite /csumb pa csumC. Qed. Definition csum_to_increasing_fun y := fun i => csum (restr y (Nintc i)). Definition csum_to_increasing_fct y n p := Lf (csum_to_increasing_fun y) (Nintc p) (Nintc n). Lemma csum_to_increasing1 y n p: natp n -> natp p -> inc y (graphs_sum_le_int p n) -> lf_axiom (csum_to_increasing_fun y) (Nintc p) (Nintc n). Proof. move=> nN pN /(setof_suml_auxP _ nN) [dy dyxx les alc] u. move /(NintcP pN) => up. have sj:(sub (Nintc u) (domain y)). rewrite dy (NintcE pN) (NintcE (NS_le_nat up pN)); exact:(proj33 (cleSS up)). have aux:= (cleT (csum_increasing1 alc sj) dyxx). by apply /(NintcP nN). Qed. Lemma csum_to_increasing2 n p: natp n -> natp p -> lf_axiom (fun y=> (csum_to_increasing_fct y n p)) (graphs_sum_le_int p n) (functions_incr_int p n). Proof. move=> nN pN y ys. move: (csum_to_increasing1 nN pN ys) => ta1. rewrite /csum_to_increasing_fct. have aa: (forall u, inc u (domain y)-> inc (Vg y u) (Nintc n)). move: ys => /funI_P [z] /Zo_S /functionsP [fz sz tg] hz udy. rewrite hz -tg; aw; move=> h; apply: Vf_target =>//. move: ys => /(setof_suml_auxP _ nN) [dy fhy les alc]. have ab: (forall u, inc u (domain y) -> inc (Vg y u) Nat). move=> u udy; apply: (Nint_S (aa _ udy)). set g:= Lf _ _ _ . have p1: function g by apply: lf_function. apply: Zo_i; first by apply /functionsP; split => //; rewrite /g;aw. have zN:= NS0. move: (Ninto_wor \0c p) => [[ok1 _ ] sr1]. move: (Ninto_wor \0c n) => [[ok2 _ ] sr2]. split => //; rewrite /g;aw; first by split; aw; try ue. move=> a b; move /Ninto_gleP => [asg bsg leab]; apply /Ninto_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. move: (asg)(bsg) => /(NintcP pN) lap /(NintcP pN) lbp. have bN:=NS_le_nat lbp pN. have aN:=NS_le_nat lap pN. rewrite (NintcE aN) (NintcE bN). set f:= restr y (csucc b). have fgf: fgraph f by rewrite /f; fprops. have si: sub (csucc b) (domain y). rewrite dy (NintcE pN); exact: (proj33 (cleSS lbp)). have df: domain f = (csucc 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 := (csucc a). have sj: sub j (domain f) by rewrite /f df; exact: (proj33 (cleSS leab)). 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: natp n -> natp p -> injection (Lf (fun y=> (csum_to_increasing_fct y n p)) (graphs_sum_le_int p n) (functions_incr_int p n)). Proof. move=> nN pN; apply: lf_injective. apply: csum_to_increasing2 =>//. rewrite /csum_to_increasing_fct. move=> u v us vs h. move: (csum_to_increasing1 nN pN vs)=> ta2. have aux: forall x, inc x (Nintc p) -> csum (restr u (Nintc x)) = csum (restr v (Nintc 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 _ nN)=> [du lesu fgu alcu]. move /(setof_suml_auxP _ nN)=> [dv lesv fgv alcv]. apply: fgraph_exten =>//; first by ue. move: (induction_on_sum3 fgu pN du alcu) => [u1 u2]. move: (induction_on_sum3 fgv pN dv alcv) => [v1 v2]. move=> x xdu. case: (equal_or_not x \0c)=> zx. rewrite zx -u1 -v1 aux =>//; apply /(NintcP pN); fprops. have xlep: x <=c p by move: xdu; rewrite du; move /(NintcP pN). have xN: inc x Nat by rewrite du in xdu; apply: (Nint_S xdu). move: (cpred_pr xN zx) => [prN xsp]. have i2:(Nint x = (Nintc (cpred x))). rewrite {1} xsp - Nint_co_cc //. have xip: inc x (Nintc p) by ue. have xpip: inc (cpred x) (Nintc p). have psp: p <=c (csucc p) by fprops. apply /(NintcP pN) /(cleSSP); fprops. by rewrite -xsp; apply:cleT xlep psp. move: (u2 _ xlep)(v2 _ xlep); rewrite - Nint_co_cc // i2. move: (ta2 _ xip); rewrite / csum_to_increasing_fun. rewrite (aux _ xip) (aux _ xpip). set A:= csum _; set B:= csum _. move=> AB h1 h2; move: (Nint_S AB) => AB1. apply: (@csum_eq2l B) => //. + have Bc: cardinalp B by rewrite /B /csum; fprops. rewrite -h1 in AB1;apply: (Nat_in_suml Bc AB1). + rewrite -h1 in AB1; apply: (Nat_in_sumr (alcu _ xdu) AB1). + rewrite du -dv in xdu. rewrite -h2 in AB1; apply: (Nat_in_sumr (alcv _ xdu) AB1). + rewrite h1 h2//. Qed. Lemma csum_to_increasing5 n p: natp n -> natp p -> surjection (Lf (fun y=> (csum_to_increasing_fct y n p)) (graphs_sum_le_int p n) (functions_incr_int p n)). Proof. move=> nN pN; apply: lf_surjective. apply: csum_to_increasing2 =>//. move =>y /Zo_P [] /functionsP [fy sy ty] iy. rewrite /graphs_sum_le_int /csum_to_increasing_fct. set E1:= Nintc p in sy iy |- *. set E2:= Nintc n in ty iy |- *. have Hb:inc \0c E1 by apply /(NintcP pN); fprops. set (a:= Vf y \0c). have aE2: inc a E2 by rewrite -ty /a; Wtac. have rec:(forall u, u<> \0c -> inc u (source y) -> exists v, [/\ inc v (source y), u = csucc 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/ (NintcP pN). have uN:= NS_le_nat up pN. move: (cpred_pr uN unz)=> [pn sp]. have cp: cardinalp (cpred u) by fprops. move: (cleS0 cp); rewrite - sp => lepu. have psy: (inc (cpred u) (source y)). rewrite sy; apply/ (NintcP pN); exact: cleT lepu up. have zN:= NS0. exists (cpred u); split=> //; move: iy => [o1 o2 [_ s1 s2] op]. have ge1: gle (Nint_cco \0c p) (cpred u) u. rewrite /E1 /Nintc in sy. apply/ (Ninto_gleP); rewrite - sy;split => //. by move: (op _ _ ge1) => /(Ninto_gleP) [_ []]. pose f i := Yo(i= \0c) 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 /(NintcP nN). rewrite - sy in i1 vsy. move : (Vf_target fy i1); rewrite ty ; move /(NintcP nN) => win. move: (cdiff_ab_le_a (Vf y v) (proj31 win)); rewrite -vp => hh. exact: (cleT hh win). set (g:= Lg E1 f). have fg: fgraph g by rewrite /g; fprops. have dg: domain g = Nintc 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: (Nint_S aux) => wN. fprops. move: (induction_on_sum3 fg pN dg cg)=> [g0 g1]. pose h i := csum (restr g (Nintc i)). have h0: (h \0c = Vf y \0c). rewrite /h g0 /g; bw; rewrite /f Y_true //. have h1: forall i, inc i E1 -> h i = Vf y i. move=> i /(NintcP pN) => ip. apply: (Nat_induction5 (r:=fun i=> h i = Vf y i) pN h0) =>//. move=> m mp; rewrite /h => hr. have mN:= NS_lt_nat mp pN. have cm: cardinalp m by fprops. have smN: natp (csucc m) by fprops. set (n1:= csucc m). have n1p: (n1 <=c p) by apply /cleSltP. move: (g1 _ n1p); rewrite /n1. rewrite - Nint_co_cc // - Nint_co_cc // hr; move=> <-. have snz: (csucc m <> \0c) by apply: succ_nz. have sm1: inc (csucc m) E1 by apply /(NintcP pN). rewrite /g; bw; rewrite /f Y_false // cpred_pr1 //. have smsy: (inc (csucc m) (source y)) by ue. move: (rec _ snz smsy) => [v [vsy smsv vp wle]]. suff mv: m = v by apply: (cdiff_pr); rewrite{1} mv. apply: succ_injective1 => //; rewrite vp; apply:CS_pred; fprops. have p1: inc g (graphs_sum_le E1 n). apply /(setof_suml_auxP _ nN); split => //. have pe1: inc p E1 by apply /(NintcP pN); 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/(NintcP nN). ex_tac. move :(csum_to_increasing1 nN pN p1) => aux. apply: function_exten => //; aw. apply: lf_function => //. rewrite sy; move=> x xsy /=; aw;rewrite -h1 //. Qed. Lemma csum_to_increasing6 n p: natp p -> natp n -> cardinal (graphs_sum_le_int p n) = binom (csucc (n +c p)) (csucc p). Proof. move=> pN nN. 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)). hnf;aw; split => //. by split; [apply: csum_to_increasing4 | apply: csum_to_increasing5]. Qed. Require Import binomial. Lemma nat_to_B_fact n: nat_to_B (n`!) = factorial (nat_to_B n). Proof. elim: n; first by rewrite factorial0 fact0 - succ_zero //. move=> n Hr; rewrite factS nat_to_B_prod Hr - nat_to_B_succ cprodC. rewrite factorial_succ //; apply: nat_to_B_Nat. Qed. Lemma nat_to_B_binom m n: nat_to_B 'C(m,n) = binom (nat_to_B m) (nat_to_B n). Proof. have H:= nat_to_B_Nat. move:m n; elim. case => //; first by rewrite binom0 -? succ_zero //; fprops. by move => m; rewrite bin0n /= binom0Sm. move => n Hr [| m]. rewrite bin0 binom0 - ? succ_zero //; apply: nat_to_B_Nat. rewrite binS nat_to_B_sum Hr Hr - !nat_to_B_succ - binomSnSm //. Qed. End IntegerProps. Export IntegerProps.