• Fundamental set theory
  • Axioms
  • Tactics
  • Constructions
  • Little
  • Complement
  • Image
  • Powerset
  • Union
  • Intersection
  • Pair
  • Cartesian products of two sets
• Theory of Sets EII-3 Correspondences
  • EII-3-1 Graphs et correspondences
  • Additional lemmas
  • EII-3-2 Inverse of a correspondence
  • EII-3-3 Composition of two correspondences
  • EII-3-4 Functions
  • EII-3-5 Restrictions and extensions of functions
  • EII-3-6 Definition of a function by means of a term
  • EII-3-7 Composition of two functions. Inverse function
  • EII-3-8 Retractions and sections
  • EII-3-9 Functions of two arguments
• Theory of Sets: EII-4 Union and intersection of a family of sets
  • EII-4-1 Definition of the union and intersection of a family of sets
  • EII-4-2 Properties of union and intersection
  • EII-4-3 Images of a union and an intersection
  • EII-4-4 complement of unions and intersections
  • EII-4-5 union and intersection of two sets
  • EII-4-6 Coverings
  • EII-4-7 Partitions
  • EII-4-8 Sum of a family of sets
• EII-5 Product of a family of sets
  • EII-5-1 The axiom of the set of subsets
  • EII-5-2 Set of mappings of one set into another
  • EII-5-3 Definition of the product of a family of sets
  • EII-5-4 Partial products
  • EII-5-5 associativity of products of sets
  • EII-5-6 distributivity formulae
  • EII-5-7 Extensions of mappings to products
• Theory of Sets EII-6 Equivalence relations
  • EII-6-1 Definition of an equivalence relation
  • EII-6-2 Equivalence classes; quotient set
  • EII-6-3 Relations compatible with an equivalence relation
  • EII-6-4 saturated subsets
  • EII-6-5 Mappings compatible with equivalence relations
  • EII-6-6 Inverse image of an equivalence relation; induced equivalence relation
  • EII-6-7 Quotients of equivalence relations
  • EII-6-8 Product of two equivalence relations
• Theory of Sets EIII-1 Order relations. Ordered sets
  • EIII-1-1 Definition of an order relation
  • Preorder relations
  • Notation and terminology
  • Ordered subsets. Product of ordered sets
  • Increasing mappings
  • Maximal and minimal elements
  • Greatest element and least element
  • Upper and lower bounds
  • Least upper bound and greatest lower bound
  • Directed sets
  • Lattices
  • Totally ordered sets
  • Intervals
• Theory of Sets EIII-2 Well ordered sets
  • EIII-2-1 Segments of a well-ordered set
  • EIII-2-2 The principle of transfinite induction
  • EIII-2-3 Zermelo's theorem
  • EIII-2-4 Inductive sets
  • EIII-2-5 Isomorphisms of well-ordered sets
  • EIII-2-6 Lexicographic Products
  • Ordinals
• Theory of Sets EIII-3 Equipotents Sets. Cardinals
  • EIII-3-1 The cardinal of a set
  • EIII-3-2 Order relation between cardinals
  • EIII-3-3 Operations on Cardinals
  • EIII-3-4 Properties of the cardinals 0 and 1
  • EIII-3-5 Exponentiation of cardinals
  • EIII-3-6 Order relation and operations on cardinals
• Theory of Sets EIII-4 Natural integers. Finite sets
  • EIII-4-1 Definition of integers
  • EIII-4-2 Inequalities between integers
  • EIII-6-1 The set of natural integers
  • EIII-4-3 The principle of induction
  • EIII-4-4 Finite subsets of ordered sets
  • EIII-4-5 Properties of finite character
  • Pseudo Ordinals

Library set9


Require Export set2.
Require Export set3.
Require Export set4.
Require Export set5.
Require Export set6.
Require Export set7.
Require Export set8.

Set Implicit Arguments.


Module IntegerProps.

Ltac autoa := auto with arith.

Hint Resolve zero_smallest: fprops.

Ltac Bnat_tac :=
  match goal with
    | H1: is_finite_c ?b, H2: cardinal_le ?a ?b |- is_finite_c ?a
      => ap (le_int_is_int H1 H2)
    | H1: cardinal_le ?a ?b, H2:inc ?b Bnat |- inc ?a Bnat
      => ap (le_int_in_Bnat H1 H2)
end.


Theorem lt_to_plus: forall a b:nat, a< b = exists c:nat, 0<c & c+a=b.
Proof. ir. ap iff_eq. ir. nin H. exists 1. ee. autoa. tv.
  nin IHle. exists (S x). ee. autoa. wrr H1.
  ir. nin H. nin H. wr H0. ap (plus_lt_compat_r 0 x a H).
Qed.

Lemma mult_lt_le_compat : forall n m p q,
  0<q -> n < m -> p <= q -> n * p < m * q.
Proof. ir. apply le_lt_trans with (n*q). autoa. app mult_lt_compat_r.
Qed.

Lemma mult_le_lt_compat : forall n m p q,
  0< m -> n <= m -> p < q -> n * p < m * q.
Proof. ir. apply le_lt_trans with (m*p). app mult_le_compat_r.
  rw mult_comm. rw (mult_comm m q). app mult_lt_compat_r.
Qed.

Lemma zero_lt_oneN: 0 < 1.
Proof. au. Qed.

Lemma lt_n_succ_leN: forall a b, a < b -> S a <= b.
Proof. ir. am. Qed.

Lemma power_of_sumN: forall a b c, a ^ (b+c) = (a ^ b) *(a ^ c).
Proof. ir. induction b. autoa. simpl. rw IHb.
  rw mult_comm. rw (mult_comm (pow a b) a). rww mult_assoc.
Qed.

Lemma power_x_0N: forall a, a ^ 0 = 1.
Proof. ir. tv. Qed.

Lemma power_0_0N: 0 ^ 0 = 1.
Proof. ap power_x_0N. Qed.

Lemma power_x_1N: forall a, a ^ 1 = a.
Proof. ir. simpl. autoa. Qed.

Lemma plus_simplifiable_leftN: forall a b b':nat,
  a + b = a + b' -> b = b'.
Proof. ir. induction a; simpl in *. am. app IHa. app eq_add_S.
Qed.

Lemma plus_simplifiable_rightN: forall a b b':nat,
  b + a = b' + a -> b = b'.
Proof. ir. rwi plus_comm H. rwi (plus_comm b' a) H.
  app (plus_simplifiable_leftN _ _ _ H).
Qed.

Lemma Sn_is_1plus: forall n, S n = 1 + n.
Proof. ir. tv. Qed.

Lemma Sn_is_plus1: forall n, S n = n +1.
Proof. ir. rw plus_comm. tv. Qed.

Lemma lt_i_n : forall i n, i< n -> 1 <= n-i.
Proof. ir. red in H. cp (le_plus_minus _ _ H). rwi Sn_is_1plus H0.
  wri plus_assoc H0. wri plus_comm H0.
  wri plus_assoc H0. wr (plus_minus _ _ _ H0).
  rw plus_comm. simpl. ap le_n_S. ap le_O_n.
Qed.

Lemma double_subN: forall n p, p <= n -> n - (n- p) = p.
Proof. ir. assert (n-p +p = n). rw plus_comm. autoa.
  symmetry in H0. sy. app plus_minus.
Qed.

Lemma mult_S_lt_reg_l : forall n m p, S n * m < S n * p -> m < p.
Proof. ir. assert (S n * m <= S n * p). app lt_le_weak.
  cp (mult_S_le_reg_l _ _ _ H0). nin (le_lt_or_eq _ _ H1). am. rwi H2 H.
  elim (lt_irrefl _ H).
Qed.

Lemma nonzero_suc: forall n, 0<>n -> exists m, n = S m.
Proof. ir. induction n. elim H. tv. exists n. tv. Qed.

Lemma mult_lt_reg_l : forall n m p, 0 <>n -> n * m < n * p -> m < p.
Proof. ir. nin (nonzero_suc H). rwi H1 H0. app (mult_S_lt_reg_l x).
Qed.
Lemma mult_lt_reg_r : forall n m p, 0 <>n -> m * n < p * n -> m < p.
Proof. ir. rwi mult_comm H0. rwi (mult_comm p n) H0.
  app (mult_lt_reg_l _ _ H H0).
Qed.

Lemma plus_n_Sm_subSn: forall n m, n + S m - n - 1 = m.
Proof. ir. sy. app plus_minus. sy. app plus_minus.
Qed.
Lemma plus_n_Sm_subSm: forall n m, n + S m - m - 1 = n.
Proof. ir. sy. app plus_minus. sy. app plus_minus. rw plus_comm.
  rw plus_assoc. rww Sn_is_plus1.
Qed.

Lemma minus_SnSi: forall i n, i < S n -> S n - i - 1 = n - i.
Proof. ir. cp (le_S_n i n H). wrr minus_Sn_m.
  assert (S(n-i) = 1+ (n-i)). tv. rw H1. app minus_plus.
Qed.

Lemma double_compl_nat:forall i n, i< n ->
  i = n - (n - i - 1) -1.
Proof. ir. red in H. cp (le_plus_minus _ _ H). app plus_minus.
  sy. app plus_minus. rw plus_comm. wr (Sn_is_1plus i).
  assert (n - i - 1 = n - S i). sy. app plus_minus. sy. app plus_minus.
  rw plus_assoc. wrr (Sn_is_plus1 i). rww H1.
Qed.

Lemma double_compl_ex:forall i n, i< n -> (n - i - 1) < n.
Proof. ir. assert (n - i - 1 = n - S i). sy. app plus_minus. sy.
  app plus_minus. rw plus_assoc. wr Sn_is_plus1. red in H. app le_plus_minus.
  rw H0. app lt_minus. autoa.
Qed.

Lemma minus_wrong: forall n m, n<=m -> n-m = 0.
Proof. ir. nin (le_lt_or_eq _ _ H). assert (~ (m<=n)). red. ir.
  rwi (le_antisym _ _ H H1) H0. app (lt_irrefl _ H0).
  app not_le_minus_0. rw H0. sy. app minus_n_n.
Qed.

Lemma pred_minus: forall n m, m<n -> n-m = S(n - S m).
Proof. ir. red in H. cp (le_plus_minus _ _ H). set (t:=n - S m) in *.
  rwi Sn_is_plus1 H0. wri plus_assoc H0. wri Sn_is_1plus H0. sy. app plus_minus.
Qed.

Lemma plus_reg_r : forall n m p, n + p = m + p -> n = m.
Proof. intros n m p. rw plus_comm; rw (plus_comm m p). ir.
  app (plus_reg_l _ _ _ H).
Qed.

Lemma domain_restr_empty: forall f, fgraph f ->
  domain (restr f emptyset) = emptyset.
Proof. ir. rww restr_domain1. ap emptyset_sub_any.
Qed.

Lemma trivial_cardinal_sum3: forall f a, fgraph f ->
  inc a (domain f) -> is_cardinal (V a f) ->
  cardinal_sum (restr f (singleton a)) = V a f.
Proof. ir.
  assert (sub (singleton a) (domain f)). red. ir. rw (singleton_eq H2). am.
  assert (V a (restr f (singleton a)) = V a f). bw. fprops.
  wri H3 H1. wr H3. app trivial_cardinal_sum1. rww restr_domain1.
Qed.

Lemma trivial_cardinal_prod3: forall f a, fgraph f ->
  inc a (domain f) -> is_cardinal (V a f) ->
  cardinal_prod (restr f (singleton a)) = V a f.
Proof. ir. assert (sub (singleton a) (domain f)). red. ir.
  rw (singleton_eq H2). am.
  assert (V a (restr f (singleton a)) = V a f). bw. fprops.
  wri H3 H1. wr H3. app trivial_cardinal_prod1. fprops. rww restr_domain1.
Qed.

Lemma partition_tack_on: forall a b, ~ inc b a ->
  partition_fam (variantLc a (singleton b)) (tack_on a b).
Proof. ir. red. ee. fprops. red. bw. ir.
  try_lvariant H0; try_lvariant H1;au; right.
  app disjoint_with_singleton.
  app disjoint_symmetric. app disjoint_with_singleton.
  uf unionb. bw. wr two_points_pr2. rw union_of_twosets_aux.
  rww variant_V_ca. rww variant_V_cb.
Qed.

Lemma partition_complement: forall a b, inc b a ->
  partition_fam (variantLc (complement a (singleton b)) (singleton b)) a.
Proof. ir. set(c:= (complement a (singleton b))).
  assert (~ (inc b c)). red. ir. ufi c H0. srwi H0.
  ee. elim H1. fprops. assert (a= tack_on c b). uf c. app tack_on_complement.
  rw H1. app partition_tack_on.
Qed.

Lemma sum_increasing6: forall f j, fgraph f ->
  (forall x, inc x (domain f) -> is_cardinal (V x f)) ->
  inc j (domain f) -> cardinal_le (V j f) (cardinal_sum f).
Proof. ir. assert (sub (singleton j) (domain f)).
  red. ir. rww (singleton_eq H2). cp (sum_increasing1 H H0 H2).
  rwii trivial_cardinal_sum3 H3. app H0.
Qed.

Lemma prod_increasing6: forall f j, fgraph f ->
  (forall x, inc x (domain f) -> is_cardinal (V x f)) ->
  (forall x, inc x (domain f) -> V x f <> card_zero) ->
  inc j (domain f) -> cardinal_le (V j f) (cardinal_prod f).
Proof. ir. assert (sub (singleton j) (domain f)).
  red. ir. rww (singleton_eq H3). cp (product_increasing1 H H0 H1 H3).
  rwii trivial_cardinal_prod3 H4. app H0.
Qed.


Definition finite_int_fam f:= fgraph f &
  (forall i, inc i (domain f) -> inc (V i f) Bnat) &
  is_finite_set (domain f).

Lemma finite_sum_finite_aux: forall f x, finite_int_fam f ->
  sub x (domain f) -> inc (cardinal_sum (restr f x)) Bnat.
Proof. ir. red in H. ee. app (finite_set_induction0 (fun x=> sub x (domain f)
    -> inc (cardinal_sum (restr f x)) Bnat)). ir.
  rw trivial_cardinal_sum. fprops. rww domain_restr_empty.
  ir. cp (partition_tack_on H4).
  set (g:= variantLc a (singleton b)).
  assert(partition_fam g (domain (restr f (tack_on a b)))). rww restr_domain1.
  assert (fgraph (restr f(tack_on a b))). fprops.
  rw (cardinal_sum_assoc H8 H7). uf g. bw. rw card_plus_pr0. bw.
  rww double_restr. rw double_restr. assert (inc b (domain f)). app H5. fprops.
  cp (H1 _ H9). rww trivial_cardinal_sum3. wr inc_Bnat. app Bnat_stable_plus.
  app H3. apply sub_trans with (tack_on a b). fprops. am. fprops. am.
  red. ir. awi H9. ue. am. fprops. app (sub_finite_set H0 H2).
Qed.

Theorem finite_sum_finite: forall f, finite_int_fam f ->
  inc (cardinal_sum f) Bnat.
Proof. ir. assert (Ha:restr f (domain f)=f). red in H; ee.
  app restr_to_domain. fprops. wr Ha. app finite_sum_finite_aux. fprops.
Qed.

Lemma finite_product_finite_aux: forall f x, finite_int_fam f ->
  sub x (domain f) -> inc (cardinal_prod (restr f x)) Bnat.
Proof. ir. red in H; ee. app (finite_set_induction0 (fun x=> sub x (domain f)
    -> inc (cardinal_prod (restr f x)) Bnat)). ir.
  rw trivial_cardinal_prod. fprops. fprops. rww domain_restr_empty. ir.
  cp (partition_tack_on H4).
  set (g:= variantLc a (singleton b)).
  assert(partition_fam g (domain (restr f (tack_on a b)))). rww restr_domain1.
  assert (fgraph (restr f(tack_on a b))). fprops.
  rw (cardinal_prod_assoc H8 H7). uf g. bw.
  rw card_mult_pr0. bw. rww double_restr. rw double_restr.
  assert (inc b (domain f)). app H5. fprops.
  cp (H1 _ H9). rww trivial_cardinal_prod3. wr inc_Bnat.
  app Bnat_stable_mult. app H3.
  apply sub_trans with (tack_on a b). fprops. am. fprops. am. red. ir. awi H9.
  ue. am. fprops. app (sub_finite_set H0 H2).
Qed.

Theorem finite_product_finite: forall f, finite_int_fam f ->
  inc (cardinal_prod f) Bnat.
Proof. ir. assert (Ha:restr f (domain f)=f). red in H; ee.
  app restr_to_domain. fprops.
  wr Ha. app finite_product_finite_aux. fprops.
Qed.

Lemma finite_union_finite: forall f, fgraph f ->
  (forall i, inc i (domain f) -> is_finite_set (V i f))
  -> is_finite_set (domain f) -> is_finite_set(unionb f).
Proof. ir. red. cp (cardinal_sum_pr1 H).
  set (g:= L (domain f) (fun a => cardinal (V a f))).
  assert (domain g = domain f). uf g. bw.
  assert (finite_int_fam g). red. ee. uf g. gprops. ir. rwi H3 H4.
  uf g. bw. app (H0 _ H4). rww H3.
  cp (cardinal_sum_pr1 H). wri H3 H1. cp (finite_sum_finite H4).
  bwi H6. Bnat_tac.
Qed.

Lemma finite_product_finite_set: forall f, fgraph f ->
  (forall i, inc i (domain f) -> is_finite_set (V i f))
  -> is_finite_set (domain f) -> is_finite_set(productb f).
Proof. ir. red. rww cardinal_prod_pr.
  set (g:= L (domain f) (fun a => cardinal (V a f))).
  assert (domain g = domain f). uf g. bw. wr inc_Bnat.
  ap finite_product_finite. red. ee. uf g. gprops. ir. rwi H2 H3. uf g. bw.
  app H0. ue.
Qed.

Lemma finite_c_set: forall b, is_finite_c b -> is_finite_set b.
Proof. ir. assert (cardinal b = b). red in H. ee. fprops. red. ue. Qed.

Lemma Bnat_stable_pow: forall a b, inc a Bnat -> inc b Bnat ->
  inc (card_pow a b) Bnat.
Proof. ir. bwi H; bwi H0. wr card_pow_pr2. app finite_product_finite.
  uf cst_graph. red. bw. ee. gprops. ir. bw. app finite_c_set.
Qed.

Lemma finite_powerset: forall a, is_finite_set a -> is_finite_set (powerset a).
Proof. ir. red. rw card_powerset. red in H.
  assert (card_pow card_two a = card_pow card_two (cardinal a)).
  app card_pow_pr. fprops. fprops. rw H0. wr inc_Bnat. app Bnat_stable_pow.
  fprops. bw.
Qed.

Hint Resolve Bnat_stable_pow: fprops.


Lemma cardinal_lt_pr: forall a b, inc a Bnat -> inc b Bnat ->
  (cardinal_lt a b = exists c, inc c Bnat & cardinal_lt card_zero c &
    card_plus c a = b).
Proof. ir. wr (nat_to_B_pr H). wr (nat_to_B_pr H0). bw. rw lt_to_plus.
  ap iff_eq. ir. nin H1. ee. exists (nat_to_B x). ee. fprops. bw. bw. ue.
  ir. nin H1. ee. wri (nat_to_B_pr H1) H2. wri (nat_to_B_pr H1) H3.
  bwi H3. bwi H2. exists (cardinal_nat x). split. am. app nat_B_inj.
Qed.


Lemma finite_sum2_lt: forall a b a' b',
  inc a Bnat -> inc b Bnat -> inc a' Bnat -> inc b' Bnat->
  cardinal_le a a' -> cardinal_lt b b' ->
  cardinal_lt (card_plus a b) (card_plus a' b').
Proof. ir. wr (nat_to_B_pr H). wr (nat_to_B_pr H0).
  wr (nat_to_B_pr H1). wr (nat_to_B_pr H2). bw.
  wri (nat_to_B_pr H) H3. wri (nat_to_B_pr H1) H3. bwi H3.
  wri (nat_to_B_pr H0) H4. wri (nat_to_B_pr H2) H4. bwi H4.
  app (plus_le_lt_compat _ _ _ _ H3 H4).
Qed.

Lemma finite_sum3_lt: forall a a' b,
  inc a Bnat -> inc b Bnat -> inc a' Bnat -> cardinal_lt a a' ->
  cardinal_lt (card_plus a b) (card_plus a' b).
Proof. ir. rw card_plus_commutative. rw (card_plus_commutative a' b).
  app finite_sum2_lt. fprops.
Qed.

Lemma lt_n_succ_le: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_le (succ a) b= cardinal_lt a b .
Proof. ir. srw. fprops. fprops.
Qed.

Lemma finite_prod2_lt: forall a b a' b',
  inc a Bnat -> inc b Bnat -> inc a' Bnat -> inc b' Bnat->
  cardinal_le a a' -> cardinal_lt b b' -> a' <> card_zero ->
  cardinal_lt (card_mult a b) (card_mult a' b').
Proof. ir. wr (nat_to_B_pr H). wr (nat_to_B_pr H0).
  wr (nat_to_B_pr H1). wr (nat_to_B_pr H2). bw.
  wri (nat_to_B_pr H) H3. wri (nat_to_B_pr H1) H3. bwi H3.
  wri (nat_to_B_pr H0) H4. wri (nat_to_B_pr H2) H4. bwi H4.
  assert (0< cardinal_nat a'). aw. red. ee. fprops. fprops.
  intuition. app (mult_le_lt_compat H6 H3 H4).
Qed.

Theorem finite_sum_lt: forall f g,
  finite_int_fam f -> finite_int_fam g -> domain f = domain g ->
  (forall i, inc i (domain f) -> cardinal_le (V i f) (V i g)) ->
  (exists i, inc i (domain f) & cardinal_lt (V i f) (V i g)) ->
  cardinal_lt (cardinal_sum f) (cardinal_sum g).
Proof. ir. nin H3. ee. cp (partition_complement H3).
  assert (Hb:inc (V x f) Bnat). red in H. ee. app H6.
  assert (Hc:inc (V x g) Bnat). red in H0. ee. app H6. wrr H1.
  assert (fgraph f). red in H. ee; am. assert (fgraph g). red in H0. ee; am.
  rw (cardinal_sum_assoc H6 H5). rwi H1 H5. rw (cardinal_sum_assoc H7 H5).
  bw. rw card_plus_pr0. rw card_plus_pr0. bw. rww trivial_cardinal_sum3.
  rww trivial_cardinal_sum3.
  assert (Ha: sub (complement (domain f) (singleton x)) (domain f)).
  app sub_complement.
  app finite_sum2_lt. app finite_sum_finite_aux. app finite_sum_finite_aux.
  wrr H1. app sum_increasing. fprops. fprops.
  rww restr_domain. rww restr_domain. ue.
  rw restr_domain1. ir. bw. srwi H8. ee. app H2.
  ue. ue. am. am. ue. fprops. fprops.
Qed.

Theorem finite_product_lt: forall f g,
  finite_int_fam f -> finite_int_fam g -> domain f = domain g ->
  (forall i, inc i (domain f) -> cardinal_le (V i f) (V i g)) ->
  (exists i, inc i (domain f) & cardinal_lt (V i f) (V i g)) ->
  (forall i, inc i (domain f) -> cardinal_lt card_zero (V i g)) ->
  cardinal_lt (cardinal_prod f) (cardinal_prod g).
Proof. ir. nin H3. ee. cp (partition_complement H3).
  assert (Hb:inc (V x f) Bnat). red in H. ee. app H7.
  assert (Hc:inc (V x g) Bnat). red in H0. ee. app H7. wrr H1.
  assert (fgraph f). red in H. ee; am. assert (fgraph g). red in H0. ee; am.
  rw (cardinal_prod_assoc H7 H6). rwi H1 H6. rw (cardinal_prod_assoc H8 H6).
  bw. rw card_mult_pr0. rw card_mult_pr0. bw.
  rww trivial_cardinal_prod3. rww trivial_cardinal_prod3.
  assert (sub (complement (domain f) (singleton x)) (domain f)).
  app sub_complement. app finite_prod2_lt. app finite_product_finite_aux.
  app finite_product_finite_aux. ue.
  app product_increasing. fprops. fprops.
  rww restr_domain. rww restr_domain. ue.
  rww restr_domain1. ir.
  bw. app H2. srwi H10; ee;am. ue. ue.
  wr zero_cardinal_product. rww restr_domain1. ir. bw.
  wri H1 H10. srwi H10. ee. cp (H4 _ H10).
  red in H12. ee. intuition. ue. ue. fprops. ue. fprops. fprops.
Qed.

Lemma special_cardinal_positive: forall a a',
  cardinal_lt a a' -> cardinal_lt card_zero a'.
Proof. ir. split. nin H. nin H. nin H1. fprops.
  red. ir. wri H0 H. app (zero_smallest1 H).
Qed.

Lemma finite_lt_a_ab: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_lt card_zero a -> cardinal_lt card_one b ->
  cardinal_lt a (card_mult a b).
Proof. ir. pose (Bnat_is_cardinal H). assert (cardinal_le a a).
  fprops. assert (a <> card_zero). red in H1. ee. intuition.
  pose (finite_prod2_lt H inc1_Bnat H H0 H3 H2 H4). rwii one_unit_prodr c.
Qed.

Lemma cardinal_le_a_apowb: forall a b,
  cardinal_lt card_zero a -> cardinal_le card_one b ->
  cardinal_le a (card_pow a b).
Proof. ir. red in H. ee. assert (cardinal_le a a). red in H; ee; fprops.
  assert (a <> card_zero). intuition.
  cp (power_increasing1 H3 H2 H0). rwi power_x_1 H4. am. red in H; ee; am.
Qed.

Lemma le_one_not_zero: forall a, cardinal_le card_one a ->
   cardinal_lt card_zero a.
Proof. ir. red. ee. red in H;ee; fprops. red. ir.
  wri H0 H. assert (cardinal_le card_zero card_one). fprops.
  cp (cardinal_antisymmetry1 H H1). app card_one_not_zero.
Qed.

Lemma non_zero_apowb: forall a b,
  cardinal_lt card_zero a -> is_cardinal b ->
  cardinal_lt card_zero (card_pow a b).
Proof. ir. cp (one_small_cardinal1 H). cp card_one_not_zero.
  assert (cardinal_le b b). red in H; ee; fprops.
  cp (power_increasing1 H2 H1 H3). rwi power_1_x H4. app le_one_not_zero.
Qed.

Lemma finite_power_lt1: forall a a' b,
  inc a Bnat -> inc a' Bnat -> inc b Bnat->
  cardinal_lt a a' -> cardinal_lt card_zero b ->
  cardinal_lt (card_pow a b) (card_pow a' b).
Proof. ir. assert (Ha:is_finite_set b). red. app finite_c_set. wrr inc_Bnat.
  wr card_pow_pr2. wr card_pow_pr2. uf cst_graph. app finite_product_lt. red.
  ee. gprops. bw. ir. bwi H. bw. bw. red. ee. gprops. bw. ir. bwi H0.
  bw. bw. bw. bw. ir. bw. nin H2. am.
  nin (emptyset_dichot b). red in H3. ee. elim H5. rw H4. app zero_is_emptyset.
  nin H4. exists y. bw. au. bw. ir. bw. app (special_cardinal_positive H2).
Qed.

Lemma finite_power_lt2: forall a b b',
  inc a Bnat -> inc b Bnat -> inc b' Bnat->
  cardinal_lt b b' -> cardinal_lt card_one a ->
  cardinal_lt (card_pow a b) (card_pow a b').
Proof. ir. assert (Ha:cardinal_lt card_zero a). red in H3. ee.
  app le_one_not_zero.
  rwi (cardinal_lt_pr H0 H1) H2. nin H2. ee. wr H5. rw power_of_sum2.
  rw card_mult_commutative. app finite_lt_a_ab. fprops. fprops.
  app non_zero_apowb. fprops. assert (cardinal_le card_one x).
  app one_small_cardinal1. cp (cardinal_le_a_apowb Ha H6). co_tac.
Qed.

Lemma lt_a_power_b_a: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_lt card_one b -> cardinal_lt a (card_pow b a).
Proof. ir. ap (cardinal_c_induction_v (fun a=> cardinal_lt a (card_pow b a))).
  rw power_x_0. fprops. app zero_lt_one. ir.
  cp (Bnat_stable_pow H0 H2). wrii lt_n_succ_le H3.
  assert (cardinal_lt (card_pow b n) (card_pow b (succ n))). uf succ.
  rw power_of_sum2. rw power_x_1. app finite_lt_a_ab. app non_zero_apowb.
  app le_one_not_zero. red in H1. ee. am. fprops. fprops. co_tac. am.
Qed.


Lemma pow_succ: forall a b, inc a Bnat -> inc b Bnat ->
  card_pow a (succ b) = card_mult(card_pow a b) a.
Proof. ir. uf succ. rw power_of_sum2. rw power_x_1. tv. fprops.
Qed.

Lemma nat_B_pow: forall n m,
  nat_to_B (n ^ m) = card_pow (nat_to_B n)(nat_to_B m).
Proof. ir. induction m. simpl. rw succ_zero. rww power_x_0.
  simpl. aw. rw pow_succ. wr IHm. tv. fprops. fprops.
Qed.

Hint Rewrite nat_B_pow: aw.
Hint Rewrite <- nat_B_pow: bw.

Lemma power_of_prodN: forall a b c,
  (a * b) ^ c = (a ^ c) * (b ^ c).
Proof. ir. app nat_B_inj. aw. wrr power_of_prod2.
Qed.

Lemma power_1_xN: forall a, 1 ^ a = 1.
Proof. ir. app nat_B_inj. aw. assert (succ (nat_to_B 0) = card_one).
  bw. ap nat_B_1. rw H. rww power_1_x.
Qed.

Lemma nat_not_zero_pr: forall a, a <> 0 -> nat_to_B a <> card_zero.
Proof. ir. red. ir. cp (nat_to_B_pr1 a). rwi H0 H1.
  rwi cardinal_nat_zero H1. elim H. sy. am.
Qed.

Lemma power_0_x: forall a, a <> 0 -> 0 ^ a = 0.
Proof. ir. app nat_B_inj. aw. rw nat_B_0. rww power_0_x.
  app nat_not_zero_pr.
Qed.

Lemma non_zero_apowbN: forall a b, 0 < a -> 0 < a ^ b.
Proof. ir. wr (nat_to_B_pr1 a). wr (nat_to_B_pr1 b). aw.
  app non_zero_apowb. bw. fprops.
Qed.

Lemma finite_power_lt1N: forall a a' b, a < a' -> 0 < b -> a ^ b < a' ^ b.
Proof. ir. wr (nat_to_B_pr1 a). wr (nat_to_B_pr1 b). wr (nat_to_B_pr1 a').
  aw. app finite_power_lt1; fprops. bw. bw.
Qed.

Lemma finite_power_lt2N: forall a b b',
  b < b' -> 1 < a -> a^ b < a ^ b'.
Proof. ir. wr (nat_to_B_pr1 a). wr (nat_to_B_pr1 b). wr (nat_to_B_pr1 b').
  aw. ap finite_power_lt2; fprops. bw. wrr nat_B_lt1.
Qed.

Lemma plus_simplifiable_left: forall a b b',
  inc a Bnat -> inc b Bnat -> inc b' Bnat ->
  card_plus a b = card_plus a b' -> b = b'.
Proof. ir. assert (is_cardinal b). fprops.
  assert (is_cardinal b'). fprops.
  assert (cardinal_le a a). fprops.
  nin (cardinal_le_total_order1 H3 H4). am. nin H6.
  cp (finite_sum2_lt H H0 H H1 H5 H6). red in H7. ee. contradiction.
  cp (finite_sum2_lt H H1 H H0 H5 H6). red in H7. ee. elim H8. sy; am.
Qed.

Lemma plus_simplifiable_right: forall a b b',
  inc a Bnat -> inc b Bnat -> inc b' Bnat ->
  card_plus b a = card_plus b' a -> b = b'.
Proof. ir. rwi card_plus_commutative H2.
  set (t:= card_plus b' a) in H2.
  assert (t= card_plus a b'). rw card_plus_commutative. tv.
  rwi H3 H2. app (plus_simplifiable_left H H0 H1 H2).
Qed.

Lemma mult_simplifiable_left: forall a b b',
  inc a Bnat -> inc b Bnat -> inc b' Bnat -> a <> card_zero ->
  card_mult a b = card_mult a b' -> b = b'.
Proof. ir. assert (is_cardinal b). fprops.
  assert (is_cardinal b'). fprops.
  assert (cardinal_le a a). fprops.
  nin (cardinal_le_total_order1 H4 H5). am. nin H7.
  cp (finite_prod2_lt H H0 H H1 H6 H7 H2). red in H8. ee. elim H9. am.
  cp (finite_prod2_lt H H1 H H0 H6 H7 H2). red in H8. ee. elim H9. sy; am.
Qed.

Lemma mult_simplifiable_right: forall a b b',
  inc a Bnat -> inc b Bnat -> inc b' Bnat -> a <> card_zero ->
  card_mult b a = card_mult b' a -> b = b'.
Proof. ir. rwi card_mult_commutative H3.
  set (t:= card_mult b' a) in H3.
  assert (t= card_mult a b'). rw card_mult_commutative. tv.
  rwi H4 H3. app (mult_simplifiable_left H H0 H1 H2).
Qed.

Lemma mult_simplifiable_leftN: forall a b b':nat,
  0 <> a -> a * b = a * b' -> b = b'.
Proof. ir. assert (nat_to_B (a * b) = nat_to_B (a * b')). rww H0.
  awi H1. app nat_B_inj. apply mult_simplifiable_left with (nat_to_B a).
  fprops. fprops. fprops. red. ir. elim H. sy. app nat_B_inj. am.
Qed.

Lemma mult_simplifiable_rightN: forall a b b',
  0 <> a -> b * a = b' * a -> b = b'.
Proof. ir. rwi mult_comm H0. rwi (mult_comm b' a) H0.
  app (mult_simplifiable_leftN _ _ H H0).
Qed.

Definition card_sub0 a b:=
  choose (fun c => inc c Bnat & card_plus b c = a).
Definition card_sub a b := Yo(cardinal_le b a) (card_sub0 a b) card_zero.

Lemma card_sub_pr0: forall a b, inc a Bnat-> inc b Bnat ->
  cardinal_le b a ->
  (inc (card_sub0 a b) Bnat & card_plus b (card_sub0 a b) = a).
Proof. ir. rwii cardinal_le_when_complement H1. nin H1. nin H1.
  uf card_sub0. app choose_pr. exists x. split. wri H2 H. bwi H. bw.
  ap (is_finite_in_sum H1 H). am. fprops. fprops.
Qed.

Lemma Bnat_stable_sub: forall a b, inc a Bnat -> inc b Bnat ->
  inc (card_sub a b) Bnat.
Proof. ir. uf card_sub. nin (p_or_not_p (cardinal_le b a)).
  rw Y_if_rw. cp (card_sub_pr0 H H0 H1). ee. am. am. rww Y_if_not_rw. fprops.
Qed.

Hint Resolve Bnat_stable_sub: fprops.

Lemma card_sub_wrong: forall a b, inc a Bnat -> inc b Bnat ->
  ~ (cardinal_le b a) -> card_sub a b = card_zero.
Proof. ir. uf card_sub. rww Y_if_not_rw. Qed.

Lemma card_sub_pr: forall a b, inc a Bnat-> inc b Bnat ->
  cardinal_le b a -> card_plus b (card_sub a b) = a.
Proof. ir. uf card_sub. rww Y_if_rw. cp (card_sub_pr0 H H0 H1). ee. am.
Qed.

Lemma card_sub_pr1: forall a b, inc a Bnat-> inc b Bnat ->
  card_sub (card_plus a b) b = a.
Proof. ir. cp (Bnat_stable_plus H H0). cp (Bnat_is_cardinal H).
  cp (Bnat_is_cardinal H0). cp (sum_increasing3 H3 H2).
  rwi card_plus_commutative H4. cp (card_sub_pr H1 H0 H4).
  rwi card_plus_commutative H5. cp (Bnat_stable_sub H1 H0).
  ap (plus_simplifiable_right H0 H6 H H5).
Qed.

Lemma card_sub_pr2: forall a b c, inc a Bnat-> inc b Bnat ->
  card_plus a b = c -> a = card_sub c b.
Proof. ir. cp (card_sub_pr1 H H0). rwi H1 H2. sy; am.
Qed.

Lemma plus_minusC: forall n m p , inc m Bnat-> inc p Bnat ->
  n = card_plus m p -> p = card_sub n m.
Proof. ir. app card_sub_pr2. sy. rww card_plus_commutative.
Qed.

Lemma nat_B_sub: forall a b,
  nat_to_B (a-b) = card_sub (nat_to_B a) (nat_to_B b).
Proof. ir.
  assert (inc (nat_to_B a) Bnat). fprops.
  assert (inc (nat_to_B b) Bnat). fprops.
  nin (p_or_not_p (b<=a)). rwi nat_B_le H1.
  cp (card_sub_pr H H0 H1). set (t:= card_sub (nat_to_B a) (nat_to_B b)) in *.
  assert (inc t Bnat). uf t. fprops. cp (nat_to_B_pr H3). wri H4 H2. bwi H2.
  cp (nat_B_inj _ _ H2). wr H5. rww minus_plus. rww not_le_minus_0.
  rwi nat_B_le H1. rww card_sub_wrong.
Qed.

Hint Rewrite nat_B_sub: aw.
Hint Rewrite <- nat_B_sub: bw.

Lemma minus_n_nC: forall a, inc a Bnat -> card_sub a a = card_zero.
Proof. ir. wr (nat_to_B_pr H). bw. wr minus_n_n. app nat_B_0.
Qed.

Lemma minus_n_0C: forall a, inc a Bnat -> card_sub a card_zero =a.
Proof. ir. wr (nat_to_B_pr H). wr nat_B_0. bw. wrr minus_n_O.
Qed.

Lemma card_sub_pr4: forall a b a' b', inc a Bnat-> inc b Bnat ->
  inc a' Bnat-> inc b' Bnat ->
  cardinal_le a b-> cardinal_le a' b' ->
  card_plus (card_sub b a) (card_sub b' a') =
  card_sub (card_plus b b') (card_plus a a').
Proof. ir. app plus_minusC. fprops. fprops.
  set (c:= (card_sub b a)). set (c':=card_sub b' a').
  rw card_plus_associative. set (t:= card_plus (card_plus a a') c).
  assert (t= card_plus (card_plus a' a) c). uf t.
  rww (card_plus_commutative a a').
  wri card_plus_associative H5. ufi c H5. rwii card_sub_pr H5.
  rw H5. rww (card_plus_commutative a' b). wr card_plus_associative.
  uf c'. rww card_sub_pr.
Qed.

Lemma card_sub_pr4N: forall a b a' b',
  a<=b -> a' <= b' -> (b-a) + (b'-a') = (b+b')- (a+a').
Proof. ir. wr (nat_to_B_pr1 a). wr (nat_to_B_pr1 b).
  wr (nat_to_B_pr1 a'). wr (nat_to_B_pr1 b'). bw. ir.
  app nat_B_inj. aw. rww card_sub_pr4; fprops. bw. bw.
Qed.

Lemma card_sub_associative: forall a b c,
  inc a Bnat -> inc b Bnat -> inc c Bnat ->
  cardinal_le (card_plus b c) a ->
  card_sub (card_sub a b) c = card_sub a (card_plus b c).
Proof. ir. set (t:= card_sub a (card_plus b c)).
  assert (card_plus b (card_plus t c) = a).
  rw card_plus_commutative. wr card_plus_associative.
  rw (card_plus_commutative c b). uf t.
  cp (card_sub_pr H (Bnat_stable_plus H0 H1) H2). rww card_plus_commutative.
  cp (Bnat_stable_sub H (Bnat_stable_plus H0 H1)). symmetry in H3.
  cp (Bnat_stable_plus H4 H1). fold t in H5. cp (plus_minusC H0 H5 H3).
  wr H6. app card_sub_pr1.
Qed.

Lemma card_sub_associativeN: forall a b c,
  (b +c) <= a -> (a-b) -c = a - (b+c).
Proof. ir. set (t:= a - (b+c)). assert (b + (t + c) = a). rw plus_comm.
  wr plus_assoc. rw (plus_comm c b). uf t. rw plus_comm. auto with arith.
  cp (minus_plus b (t+c)). rwi H0 H1. rw H1. rw plus_comm. ap minus_plus.
Qed.

Lemma prec_pr1: forall a, inc a Bnat -> a <> card_zero
  -> predc a = card_sub a card_one.
Proof. ir. assert (cardinal_le card_one a). app one_small_cardinal. fprops.
  cp (card_sub_pr H inc1_Bnat H1). cp (Bnat_stable_sub H inc1_Bnat).
  bwi H. cp (predc_pr H H0). ee.
  fold succ in H2. set (t:= card_sub a card_one). assert (succ t = a).
  uf t. uf succ. rw card_plus_commutative. am.
  assert (succ (predc a) = succ t). wr H5. sy; am. app succ_injective.
  red in H4. ee; am. uf t. fprops.
Qed.

Lemma nat_B_pred: forall a, 0 <> a -> nat_to_B (pred a) = predc (nat_to_B a).
Proof. ir. rww prec_pr1. wr nat_B_1. bw. rww pred_of_minus. fprops.
  wr nat_B_0. red. ir. elim H. sy. app (nat_B_inj _ _ H0).
Qed.

Lemma card_sub_non_zero: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_le (succ b) a -> card_sub a b <> card_zero.
Proof. ir. assert (card_plus (succ b) (card_sub a (succ b))= a).
  app card_sub_pr. fprops. ufi succ H2. wri card_plus_associative H2.
  assert (inc (card_plus card_one (card_sub a (succ b))) Bnat). fprops.
  symmetry in H2. wr (plus_minusC H0 H3 H2).
  assert (is_cardinal card_one). fprops.
  assert (is_cardinal (card_sub a (succ b))).
  assert (inc (card_sub a (succ b)) Bnat). fprops. fprops.
  cp (sum_increasing3 H4 H5). red. ir. rwi H7 H6.
  assert (cardinal_lt card_one card_zero). red. ee. am. ap (card_one_not_zero).
  elim (zero_smallest1 H8).
Qed.

Lemma card_sub_associative1: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_le (succ b) a -> predc (card_sub a b) = card_sub a (succ b).
Proof. uf succ. ir. wrr card_sub_associative. app prec_pr1. fprops.
  app card_sub_non_zero. fprops.
Qed.

Lemma card_sub_associative1N: forall a b,
  (S b) <= a -> pred (a - b) = a - S b.
Proof. ir. rw Sn_is_plus1. rw pred_of_minus. app card_sub_associativeN.
  wrr Sn_is_plus1.
Qed.

Lemma sub_le_symmetry: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_le b a -> cardinal_le (card_sub a b) a.
Proof. ir. cp (card_sub_pr H H0 H1).
  set (t:= card_sub a b) in *. wr H2. rw card_plus_commutative.
  app sum_increasing3. uf t. fprops. fprops.
Qed.

Lemma sub_lt_symmetry: forall n p,
  inc p Bnat -> cardinal_lt n p ->
  cardinal_lt (predc (card_sub p n)) p.
Proof. ir. nin H0. assert (inc n Bnat). bwi H. bw.
  Bnat_tac. cp (card_sub_pr H H2 H0).
  assert ((card_sub p n) <> card_zero). red. ir. rwi H4 H3. awi H3.
  contradiction. fprops.
  assert (inc (card_sub p n) Bnat). fprops. bwi H5.
  nin (predc_pr H5 H4). ee. wr lt_n_succ_le. wr H7. app sub_le_symmetry.
  bw. am.
Qed.

Lemma double_sub: forall n p, Bnat_le p n ->
  card_sub n (card_sub n p) = p.
Proof. ir. red in H. ee.
  assert (card_plus (card_sub n p) p = n). rw card_plus_commutative.
  app card_sub_pr. symmetry in H2. sy. app plus_minusC. fprops.
Qed.

Lemma Bnat_le_reflexive: forall a, inc a Bnat -> Bnat_le a a.
Proof. ir. red. ee. am. am. fprops.
Qed.

Lemma Bnat_le_transitive: forall a b c, Bnat_le a b -> Bnat_le b c ->
  Bnat_le a c.
Proof. intros a b c. repeat wr Bnat_order_le. ir.
  nin Bnat_order_worder. order_tac.
Qed.

Lemma Bnat_le_antisymmetric: forall a b, Bnat_le a b -> Bnat_le b a -> a = b.
Proof. intros a b. repeat wr Bnat_order_le. ir. nin Bnat_order_worder.
  order_tac.
Qed.

Lemma Bnat_total_order: forall a b, inc a Bnat -> inc b Bnat ->
  Bnat_le a b \/ Bnat_lt b a.
Proof. intros a b. uf Bnat_lt. repeat wr Bnat_order_le. ir.
  cp Bnat_order_worder. cp (worder_total H1). nin H2.
  nin (equal_or_not a b). rw H4. left. order_tac.
  rww Bnat_order_substrate. rwi Bnat_order_substrate H3. nin (H3 _ _ H H0); au.
Qed.

Lemma Bnat_zero_smallest: forall a, inc a Bnat -> Bnat_le card_zero a.
Proof. ir. red. ee. fprops. am. fprops.
Qed.

Lemma Bnat_zero_smallest1: forall a, Bnat_le a card_zero -> a = card_zero.
Proof. ir. cp H. red in H. ee. cp (Bnat_zero_smallest H).
  app Bnat_le_antisymmetric.
Qed.

Lemma Bnat_plus_le_simplifiable: forall a b c,
  inc a Bnat -> inc b Bnat -> inc c Bnat->
  cardinal_le (card_plus a b) (card_plus a c) -> cardinal_le b c.
Proof. ir. assert (is_cardinal b). fprops.
  assert (is_cardinal c). fprops.
  nin (cardinal_le_total_order1 H3 H4). rw H5. fprops. nin H5.
  red in H5. ee; am. assert (cardinal_le a a). fprops.
  cp (finite_sum2_lt H H1 H H0 H6 H5). co_tac.
Qed.

Lemma Bnat_plus_lt_simplifiable: forall a b c,
  inc a Bnat -> inc b Bnat -> inc c Bnat->
  cardinal_lt (card_plus a b) (card_plus a c) -> cardinal_lt b c.
Proof. ir. red in H2. ee. red. ee. ap (Bnat_plus_le_simplifiable H H0 H1 H2).
  red. ir. elim H3. rww H4.
Qed.

Lemma Bnat_mult_le_simplifiable: forall a b c,
  inc a Bnat -> inc b Bnat -> inc c Bnat-> a <> card_zero ->
  cardinal_le (card_mult a b) (card_mult a c) -> cardinal_le b c.
Proof. ir. assert (is_cardinal b). fprops.
  assert (is_cardinal c). fprops.
  nin (cardinal_le_total_order1 H4 H5). rw H6. fprops. nin H6.
  red in H6. ee; am. assert (cardinal_le a a). fprops.
  cp (finite_prod2_lt H H1 H H0 H7 H6 H2). co_tac.
Qed.

Lemma Bnat_mult_lt_simplifiable: forall a b c,
  inc a Bnat -> inc b Bnat -> inc c Bnat-> a <> card_zero ->
  cardinal_lt (card_mult a b) (card_mult a c) -> cardinal_lt b c.
Proof. ir. red in H3. ee. red. ee.
  ap (Bnat_mult_le_simplifiable H H0 H1 H2 H3). dneg. ue.
Qed.

Lemma is_finite_in_product: forall a b, is_cardinal a -> is_cardinal b ->
  b <> card_zero -> is_finite_c (card_mult a b) -> is_finite_c a.
Proof. ir. red. ee. am. dneg. set (x:= card_mult a b) in *.
  assert (x= card_mult a b). tv. rwi H3 H4. ufi succ H4.
  rwi cardinal_distrib_prod_sum2 H4. fold x in H4. rwii one_unit_prodl H4.
  assert (card_plus x card_zero = card_plus x b). rww zero_unit_sumr. fprops.
  sy. cp H2. wri inc_Bnat H2. rwi H4 H6.
  cp (is_finite_in_sum H0 H6). wri inc_Bnat H7.
  ap (plus_simplifiable_left H2 inc0_Bnat H7 H5).
Qed.

Definition interval_Bnat a b := interval_cc Bnat_order a b.
Definition interval_co_0a a:= interval_co Bnat_order card_zero a.
Definition interval_Bnato a b :=
  graph_on cardinal_le (interval_cc Bnat_order a b).
Definition interval_Bnatco a :=
  graph_on cardinal_le (interval_co_0a a).

Lemma interval_Bnat_pr: forall a b x, inc a Bnat -> inc b Bnat ->
  inc x (interval_Bnat a b) = (Bnat_le a x & Bnat_le x b).
Proof. uf interval_Bnat. app Bnat_interval_cc_pr.
Qed.

Hint Rewrite interval_Bnat_pr : sw.

Lemma interval_Bnat_pr0: forall b x, inc b Bnat ->
  inc x (interval_Bnat card_zero b) = cardinal_le x b.
Proof. ir. srw. uf Bnat_le. app iff_eq. ir. ee. am. ir.
  assert (inc x Bnat). bw. bwi H. Bnat_tac.
  ee. fprops. am. app zero_smallest. fprops. am. am. am. fprops.
Qed.

Lemma sub_interval_Bnat: forall a b,
  sub (interval_Bnat a b) Bnat.
Proof. ir. uf interval_Bnat. uf interval_cc. rw Bnat_order_substrate.
  app Z_sub.
Qed.

Lemma sub_interval_co_0a_Bnat: forall a, sub (interval_co_0a a) Bnat.
Proof. ir. uf interval_co_0a. uf interval_co. rw Bnat_order_substrate.
  app Z_sub.
Qed.

Lemma interval_co_0a_pr2: forall a x, inc a Bnat ->
  inc x (interval_co_0a a) = cardinal_lt x a.
Proof. ir. uf interval_co_0a. rw Bnat_interval_co_pr1. app iff_eq. ir.
  ee. am. ir. ee. app zero_smallest. nin H0. nin H0. am. am.
  fprops. am.
Qed.

Hint Rewrite interval_co_0a_pr2 : sw.

Lemma interval_co_0a_pr3: forall a x, inc a Bnat ->
  inc x (interval_co_0a (succ a)) = cardinal_le x a.
Proof. ir. srw. fprops. fprops.
Qed.

Lemma interval_co_cc: forall p, inc p Bnat ->
  interval_Bnat card_zero p = interval_co_0a (succ p).
Proof. ir. set_extens. rww interval_co_0a_pr3. rwi interval_Bnat_pr0 H0. am. am.
  rwi interval_co_0a_pr3 H0. rww interval_Bnat_pr0. am.
Qed.

Lemma interval_cc_0a_increasing: forall a b, inc b Bnat ->
  cardinal_le a b ->
  sub (interval_Bnat card_zero a) (interval_Bnat card_zero b).
Proof. ir. uf interval_Bnat. red. ir. rwi interval_Bnat_pr0 H1.
  rww interval_Bnat_pr0. co_tac. Bnat_tac.
Qed.

Lemma interval_cc_0a_increasing1: forall a, inc a Bnat ->
  sub (interval_Bnat card_zero a) (interval_Bnat card_zero (succ a)).
Proof. ir. app interval_cc_0a_increasing. fprops. app is_less_than_succ.
  fprops.
Qed.

Lemma inc_a_interval_co_succ: forall a, inc a Bnat ->
  inc a (interval_co_0a (succ a)).
Proof. ir. srw. fprops. fprops. fprops.
Qed.

Lemma interval_co_0a_increasing: forall a, inc a Bnat ->
  sub (interval_co_0a a) (interval_co_0a (succ a)).
Proof. ir. red. ir. srw.
  cp (sub_interval_co_0a_Bnat H0). srwi H0.
  nin H0; am. am. fprops. fprops.
Qed.

Lemma interval_co_0a_increasing1: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_le a b -> sub (interval_co_0a a) (interval_co_0a b).
Proof. ir. uf interval_co_0a. red. ir. rwi Bnat_interval_co_pr1 H2. ee.
  rw Bnat_interval_co_pr1. ee. am. co_tac.
  fprops. am. fprops. am.
Qed.

Lemma interval_co_pr4: forall n, inc n Bnat ->
  ( (tack_on (interval_co_0a n) n = (interval_co_0a (succ n)))
    & ~(inc n (interval_co_0a n))).
Proof. ir. assert (inc (succ n) Bnat). fprops.
  assert (Ha:is_finite_c n). wrr inc_Bnat.
  split. set_extens. srw. rwii tack_on_inc H1.
  nin H1. srwi H1. nin H1; am. am. rw H1. fprops.
  srwi H1. nin (equal_or_not x n). rw H2. fprops.
  assert (inc x (interval_co_0a n)). srw. split; am. fprops. am. am.
  red. ir. srwi H1. nin H1. elim H2. tv. am.
Qed.

Lemma cardinal_c_induction5_v: forall (r:EP) a,
  inc a Bnat -> r card_zero ->
  (forall n, cardinal_lt n a -> r n -> r (succ n))
  -> (forall n, cardinal_le n a -> r n).
Proof. ir. app (cardinal_c_induction3_v r inc0_Bnat H H0). ir.
  srwi H3. app H1. am. rww interval_Bnat_pr0.
Qed.

Lemma interval_Bnato_worder: forall a b, inc a Bnat -> inc b Bnat ->
  worder (interval_Bnato a b).
Proof. uf interval_Bnato. ir. cp wordering_cardinal_le.
  assert (forall x, inc x (interval_cc Bnat_order a b) -> cardinal_le x x). ir.
  srwi H2. ee. red in H2. ee. cp (Bnat_is_cardinal H4).
  fprops. am. am. cp (wordering_pr H1 H2). ee. am.
Qed.

Lemma interval_Bnato_substrate: forall a b, inc a Bnat -> inc b Bnat ->
  substrate (interval_Bnato a b) = interval_Bnat a b.
Proof. ir. cp wordering_cardinal_le.
  assert (forall x, inc x (interval_Bnat a b) -> cardinal_le x x). ir.
  assert (inc x Bnat). app (sub_interval_Bnat H2). fprops.
  cp (wordering_pr H1 H2). ee. am.
Qed.

Lemma interval_Bnato_related: forall a b x y, inc a Bnat -> inc b Bnat ->
  gle (interval_Bnato a b) x y = (inc x (interval_Bnat a b) &
    inc y (interval_Bnat a b) & cardinal_le x y).
Proof. ir. uf interval_Bnato. aw. rw graph_on_rw1. tv.
Qed.

Lemma interval_Bnato_related1: forall a b x y, inc a Bnat -> inc b Bnat ->
  gle (interval_Bnato a b) x y = (cardinal_le a x &
  cardinal_le a y & cardinal_le x b & cardinal_le y b& cardinal_le x y).
Proof. ir. rww interval_Bnato_related. srw.
  uf Bnat_le. app iff_eq. ir. intuition. ir.
  nin H1. nin H2. nin H3. nin H4. assert (inc x Bnat). bw.
  bwi H0. Bnat_tac. assert (inc y Bnat).
  bw. bwi H0. Bnat_tac. intuition.
Qed.

Lemma interval_Bnato_related2: forall a b x y, inc a Bnat -> inc b Bnat ->
  gle (interval_Bnato a b) x y = (cardinal_le a x
    & cardinal_le y b& cardinal_le x y).
Proof. ir. rww interval_Bnato_related1. ap iff_eq. ir. intuition. ir. ee.
  am. co_tac. co_tac. am. am.
Qed.

Lemma interval_Bnatco_worder: forall a, inc a Bnat ->
  worder (interval_Bnatco a).
Proof. ir. uf interval_Bnatco. ir. cp wordering_cardinal_le.
  assert (forall x, inc x (interval_co_0a a) -> cardinal_le x x). ir.
  assert (inc x Bnat). app (sub_interval_co_0a_Bnat H1). fprops.
  nin (wordering_pr H0 H1). am.
Qed.

Lemma interval_Bnatco_substrate: forall a, inc a Bnat ->
  substrate (interval_Bnatco a) = interval_co_0a a.
Proof. ir. uf interval_Bnatco. ir. cp wordering_cardinal_le.
  assert (forall x, inc x (interval_co_0a a) -> cardinal_le x x). ir.
  assert (inc x Bnat). app (sub_interval_co_0a_Bnat H1). fprops.
  nin (wordering_pr H0 H1). am.
Qed.

Lemma interval_Bnatco_related: forall a x y, inc a Bnat ->
  gle (interval_Bnatco a) x y = (cardinal_le x y & cardinal_lt y a).
Proof. ir. uf interval_Bnatco. rw graph_on_rw1. srw.
  app iff_eq. ir. ee; am. ir. ee; try am. co_tac.
Qed.

Definition rest_plus_interval a b :=
  BL(fun z => card_plus z b)(interval_Bnat card_zero a)
    (interval_Bnat b (card_plus a b)).

Definition rest_minus_interval a b :=
  BL(fun z => card_sub z b) (interval_Bnat b (card_plus a b))
  (interval_Bnat card_zero a).

Lemma sum_increasing5: forall a b, inc a Bnat -> inc b Bnat ->
  Bnat_le a (card_plus a b).
Proof. ir. red. ee. am. fprops. app sum_increasing3. fprops. fprops.
Qed.

Lemma sum_increasing4: forall a b a' b',
  Bnat_le a a' -> Bnat_le b b' ->
  Bnat_le (card_plus a b) (card_plus a' b').
Proof. ir. red. red in H. red in H0. ee. fprops. fprops. app sum_increasing2.
Qed.

Lemma sub_increasing2: forall a b c, inc a Bnat -> inc b Bnat -> inc c Bnat->
  cardinal_le c (card_plus a b) -> cardinal_le b c ->
  cardinal_le (card_sub c b) a.
Proof. ir. app (Bnat_plus_le_simplifiable (a:= b)). fprops.
  rww card_sub_pr. rw card_plus_commutative. am.
Qed.

Lemma rest_plus_interval_axioms: forall a b, inc a Bnat -> inc b Bnat ->
  transf_axioms (fun z => card_plus z b)(interval_Bnat card_zero a)
    (interval_Bnat b (card_plus a b)).
Proof. ir. red. ir. cp (Bnat_stable_plus H H0). srwi H1. srw. ee.
  rw card_plus_commutative. app sum_increasing5. red in H3. ee; am.
  app sum_increasing4. app Bnat_le_reflexive. fprops. am.
Qed.

Lemma rest_minus_interval_axioms: forall a b, inc a Bnat -> inc b Bnat ->
  transf_axioms (fun z => card_sub z b) (interval_Bnat b (card_plus a b))
  (interval_Bnat card_zero a).
Proof. ir. red. ee. ir. cp (Bnat_stable_plus H H0). srwi H1.
  ee. srw. cp H1. red in H1. nin H1. nin H5.
  cp (Bnat_stable_sub H5 H1). ee. ap Bnat_zero_smallest. am. red. ee.
  am. am. app sub_increasing2. red in H3; ee; am. fprops. am. am.
Qed.

Lemma restr_plus_minus_bij: forall a b, inc a Bnat -> inc b Bnat ->
  (bijective (rest_plus_interval a b) & bijective (rest_minus_interval a b)
    & (rest_minus_interval a b) = inverse_fun (rest_plus_interval a b)).
Proof. ir. cp (rest_minus_interval_axioms H H0).
  cp (rest_plus_interval_axioms H H0).
  set (f:= rest_plus_interval a b). set (g:= rest_minus_interval a b).
  assert (is_function f). uf f. uf rest_plus_interval. app bl_function.
  assert (is_function g). uf g. uf rest_minus_interval. app bl_function.
  assert (composable f g). red. ee. am. am. uf f; uf g.
  uf rest_plus_interval; uf rest_minus_interval. aw.
  assert (composable g f). red. ee. am. am. uf f; uf g.
  uf rest_plus_interval; uf rest_minus_interval. aw.
  app bijective_from_compose. uf f. uf g.
  uf rest_minus_interval. uf rest_plus_interval.
  app function_exten. fct_tac. fprops.
  aw. aw. aw. ir. aw. rww identity_W. rww card_sub_pr1.
  cp inc0_Bnat. rwi (interval_Bnat_pr x H8 H) H7. ee. red in H7; ee; am.
  aw. red in H2. app H2. uf f. uf g.
  uf rest_minus_interval. uf rest_plus_interval.
  app function_exten. fct_tac. fprops.
  aw. aw. aw. ir. aw. rww identity_W. rw card_plus_commutative.
  cp (Bnat_stable_plus H H0). rwi (interval_Bnat_pr x H0 H8) H7. ee.
  red in H7; ee. rww card_sub_pr. aw. red in H1. app H1.
Qed.

Theorem restr_plus_interval_isomorphism: forall a b, inc a Bnat -> inc b Bnat->
  order_isomorphism (rest_plus_interval a b)
  (interval_Bnato card_zero a)
  (interval_Bnato b (card_plus a b)).
Proof. ir. cp (inc0_Bnat). cp (Bnat_stable_plus H H0).
  assert (Ha:interval_Bnat card_zero a = source (rest_plus_interval a b)).
  uf rest_plus_interval. aw.
  nin (interval_Bnato_worder H1 H). nin (interval_Bnato_worder H0 H2).
  cp (rest_plus_interval_axioms H H0).
  red. ee. am. am. cp (restr_plus_minus_bij H H0). ee; am.
  rww interval_Bnato_substrate. uf rest_plus_interval.
  rww interval_Bnato_substrate. aw. wr Ha. ir. rww interval_Bnato_related.
  rww interval_Bnato_related. uf rest_plus_interval. aw. app iff_eq. ir. ee.
  app H7. app H7.
  app sum_increasing2. cp (Bnat_is_cardinal H0). fprops. ir. ee. am. am.
  rwi (card_plus_commutative x b) H12.
  rwi (card_plus_commutative y b) H12. srwi H8. srwi H9.
  ee. red in H8. red in H9. ee.
  ap (Bnat_plus_le_simplifiable H0 H17 H15 H12). fprops. am. fprops. am.
Qed.

Lemma cardinal_interval0a: forall a, inc a Bnat ->
  cardinal (interval_Bnat card_zero a) = succ a.
Proof. ir. set (r:= fun a => cardinal (interval_Bnat card_zero a)= succ a).
  cp inc0_Bnat. app (cardinal_c_induction_v r). uf r. rw succ_zero.
  nin Bnat_order_worder. assert (inc card_zero (substrate Bnat_order)).
  rw Bnat_order_substrate. fprops. nin (singleton_interval H1 H3).
  uf interval_Bnat. rw H4. app cardinal_singleton.
  uf r. ir. cp (inc_succ_Bnat H1). assert (is_finite_c n). wrr inc_Bnat.
  assert (interval_Bnat card_zero (succ n) =
    tack_on (interval_Bnat card_zero n) (succ n)). set_extens.
  rwi interval_Bnat_pr0 H5. nin (equal_or_not x (succ n)). rw H6.
  fprops. assert (inc x (interval_Bnat card_zero n)). rww interval_Bnat_pr0.
  wrr lt_is_le_succ. red;ee;am. fprops. am.
  rw interval_Bnat_pr0. rwi tack_on_inc H5. nin H5. rwi interval_Bnat_pr0 H5.
  apply cardinal_le_transitive with n. am. fprops. app is_less_than_succ.
  fprops. am. rw H5. fprops. am.
  assert (~ (inc (succ n) (interval_Bnat card_zero n))). red. ir.
  rwi interval_Bnat_pr0 H6. wri lt_is_le_succ H6. red in H6. ee. elim H7. tv.
  am. am. rw H5. rww cardinal_succ_pr. wr H2. rww succ_cardinal.
Qed.

Theorem cardinal_interval: forall a b, Bnat_le a b->
  cardinal (interval_Bnat a b) = succ (card_sub b a).
Proof. ir. red in H. ee. cp (card_sub_pr H0 H H1).
  cp (Bnat_stable_sub H0 H). set (c:= card_sub b a) in *.
  cp (restr_plus_minus_bij H3 H). ee.
  assert (equipotent (interval_Bnat card_zero c) (interval_Bnat a b)).
  exists (rest_plus_interval c a). ee. am. uf rest_plus_interval. aw.
  uf rest_plus_interval. aw. rwi card_plus_commutative H2. rww H2.
  wr (cardinal_interval0a H3). sy. rww cardinal_equipotent.
Qed.

Lemma finite_set_interval_Bnat: forall a b, Bnat_le a b ->
  is_finite_set (interval_Bnat a b).
Proof. ir. red. rww cardinal_interval. wr inc_Bnat. red in H; ee. fprops.
Qed.

Lemma finite_set_interval_co: forall a, inc a Bnat ->
  is_finite_set (interval_co Bnat_order card_zero a).
Proof. ir.
  assert (sub (interval_co Bnat_order card_zero a)(interval_Bnat card_zero a)).
  red. ir. rww interval_Bnat_pr0. srwi H0. nin H0; am. am.
  assert (is_finite_set (interval_Bnat card_zero a)).
  app finite_set_interval_Bnat. app Bnat_zero_smallest.
  app (sub_finite_set H0 H1).
Qed.

Lemma Bnat_infinite: ~(is_finite_set Bnat).
Proof. red. ir. red in H. wri inc_Bnat H.
  cp (sub_smaller (sub_interval_Bnat (a:=card_zero) (b:=cardinal Bnat))).
  rwi (cardinal_interval0a H) H0. srwi H0; fprops. nin H0. auto.
Qed.

Lemma cardinal_interval1a: forall a, inc a Bnat ->
  cardinal (interval_Bnat card_one a) = a.
Proof. ir. nin (equal_or_not a card_zero). rw H0.
  assert (interval_Bnat card_one card_zero= emptyset). app is_emptyset.
  red. ir. srwi H1. ufi Bnat_le H1. nin H1. ee.
  cp (zero_smallest2 H4). rwi H7 H6. cp zero_lt_one. co_tac.
  fprops. fprops. ue.
  assert (Bnat_le card_one a). red. ee. fprops. am.
  app one_small_cardinal. fprops. rww cardinal_interval.
  uf succ. rw card_plus_commutative. red in H1. ee. app card_sub_pr.
Qed.

Lemma isomorphism_worder_finite: forall r r', total_order r -> total_order r' ->
  is_finite_set (substrate r) -> equipotent (substrate r) (substrate r') ->
  exists_unique (fun f => order_isomorphism f r r').
Proof. ir. wri cardinal_equipotent H2. assert (is_finite_set (substrate r')).
  red. wrr H2.
  cp (finite_set_torder_worder H H1). cp (finite_set_torder_worder H0 H3).
  cp (isomorphism_worder H4 H5). nin H6. nin H6. red. nin H6. ee. red in H8.
  exists x. red. ee; try am. app bijective_if_same_finite_c_inj. wr H11.
  wrr H12. wrr H11. ir. red in H9; red in H10. ee.
  red in H17; red in H12; ee. app H7. ee.
  assert (range (graph x0) = substrate r'). rw H19. app surjective_pr3.
  rw H23. app substrate_is_segment. red; ee; am.
  ee. assert (range (graph y) = substrate r').
  rw H14. app surjective_pr3. rw H23. app substrate_is_segment. red; ee; am.
  nin H6. red. nin H6. ee.
  assert (order_isomorphism x r' r). red in H8. ee. red. ee; try am.
  app bijective_if_same_finite_c_inj. wr H11; wr H12. sy;am. wrr H11.
  cp (inverse_order_isomorphism H9). exists (inverse_fun x). am.
  ir. cp (inverse_order_isomorphism H9). cp (inverse_order_isomorphism H10).
  assert (inverse_fun x0 = inverse_fun y).
  red in H11; red in H12. ee. red in H19; red in H14; ee. app H7. ee.
  assert (range (graph (inverse_fun x0)) = substrate r). rw H21.
  app surjective_pr3. rw H25. app substrate_is_segment. red; ee; am.
  ee. assert (range (graph (inverse_fun y)) = substrate r).
  rw H16. app surjective_pr3. rw H25. app substrate_is_segment. red; ee; am.
  assert (is_correspondence x0). red in H9. ee. red in H15. ee.
  red in H15. ee. red in H15. ee. am. wr (inverse_fun_involutive H14).
  assert (is_correspondence y). red in H10. ee. red in H16. ee.
  red in H16. ee. red in H16. ee. am. wr (inverse_fun_involutive H15).
  rww H13.
Qed.

Theorem finite_ordered_interval: forall r, total_order r ->
  is_finite_set (substrate r) ->
  exists_unique (fun f => order_isomorphism f r
    (interval_Bnato card_one (cardinal (substrate r)))).
Proof. ir. cp (finite_set_torder_worder H H0). cp H0. red in H0.
  wri inc_Bnat H0. cp (cardinal_interval1a H0). symmetry in H3.
  rwi cardinal_equipotent H3. wri interval_Bnato_substrate H3.
  cp (worder_total (interval_Bnato_worder inc1_Bnat H0)).
  app (isomorphism_worder_finite H H4 H2 H3). fprops. am.
Qed.

Lemma cardinal_interval_co_0a: forall a, inc a Bnat -> a <> card_zero ->
  cardinal (interval_Bnat card_zero (predc a)) = a.
Proof. ir. rwi inc_Bnat H. cp (predc_pr H H0). ee.
  assert (Bnat_le card_zero (predc a)). red. ee. fprops. bw.
  app zero_smallest. red in H1; ee; am. rw (cardinal_interval H3).
  rw minus_n_0C. sy; am. bw.
Qed.

Lemma interval_co_0a_pr: forall a x, inc a Bnat -> a <> card_zero ->
  inc x (interval_Bnat card_zero (predc a)) = (inc x Bnat & cardinal_lt x a).
Proof. ir. bwi H. cp (predc_pr H H0). ee. cp inc0_Bnat.
  assert (inc (predc a) Bnat). bw. app iff_eq. ir. srwi H5.
  ee. red in H5; ee; am. red in H6. ee. rw H2. srw. fprops. am.
  ir. srw. ee. app Bnat_zero_smallest. red. ee. am. am. rwi H2 H6. srwi H6.
  am. am.
Qed.

Lemma interval_co_0a_pr1: forall a, inc a Bnat -> a <> card_zero ->
  interval_Bnat card_zero (predc a) = interval_co_0a a.
Proof. ir. uf interval_co_0a.
  set_extens. rwi interval_co_0a_pr H1. rw Bnat_interval_co_pr1.
  ee. app zero_smallest. fprops. am. fprops. am. am. am.
  rw interval_co_0a_pr. rwi Bnat_interval_co_pr1 H1. ee. red in H2. ee.
  bw. bwi H. Bnat_tac. am. fprops. am. am. am.
Qed.

Lemma cardinal_interval_co_0a1: forall a, inc a Bnat ->
  cardinal (interval_co_0a a) = a.
Proof. ir. nin (equal_or_not a card_zero). rw H0.
  assert(interval_co_0a card_zero = emptyset). app is_emptyset. red. ir.
  srwi H1. ee. app (zero_smallest1 H1). fprops.
  rw H1. fprops. wrr interval_co_0a_pr1. app cardinal_interval_co_0a.
Qed.

Lemma emptyset_interval_00: interval_co_0a card_zero = emptyset.
Proof. app cardinal_nonemptyset. rww cardinal_interval_co_0a1. ap inc0_Bnat.
Qed.

Theorem finite_ordered_interval1: forall r, total_order r ->
  is_finite_set (substrate r) ->
  exists_unique (fun f => order_isomorphism f r
    (interval_Bnatco (cardinal (substrate r)))).
Proof. ir. cp (finite_set_torder_worder H H0). cp H0. red in H0.
  wri inc_Bnat H0. cp (cardinal_interval_co_0a1 H0). symmetry in H3.
  rwi cardinal_equipotent H3. wri interval_Bnatco_substrate H3.
  cp (worder_total (interval_Bnatco_worder H0)).
  app (isomorphism_worder_finite H H4 H2 H3). fprops.
Qed.

Require Import List.

Lemma list_extens: forall (A:Type) (l1 l2 : list A) (u:A),
   length l1 = length l2 ->
   (forall i, i< length l1 -> nth i l1 u = nth i l2 u) -> l1 = l2.
Proof. intros A l1. induction l1. ir. induction l2. tv. simpl in H.
  elim (O_S _ H). ir. induction l2. simpl in H. symmetry in H. elim (O_S _ H).
  simpl in H. cp (eq_add_S _ _ H). cut (l1=l2). ir.
  assert (0< length (a :: l1)). simpl. red. app le_n_S. app le_O_n.
  cp (H0 _ H3). simpl in H4. ue. ue. app (IHl1 l2 u H1). ir.
  assert (S i < length (a :: l1)). simpl. app lt_n_S. cp (H0 _ H3). am.
Qed.

Fixpoint fct_to_list_rev (A:Type) (f: nat->A)(n:nat): list A :=
  match n with O => nil
    | S m => (f m) ::(fct_to_list_rev f m) end.

Definition fct_to_list A f n := rev (fct_to_list_rev (A:=A) f n).

Definition list_to_fct (a: list nat) :=
  fun n => nth n a 0.

Definition list_to_fctB (a: list Set) :=
  fun n => nth n a emptyset.

Lemma fct_to_list_length : forall A (f:nat->A) n,
  length (fct_to_list f n) = n.
Proof. ir. uf fct_to_list. rw rev_length.
  induction n. uf fct_to_list. tv. simpl. rww IHn.
Qed.

Lemma card_interval_c0_pr: forall n,
  cardinal_nat (interval_co_0a (nat_to_B n)) = n.
Proof. ir. wr cardinal_nat_cardinal.
  rw cardinal_interval_co_0a1. aw. fprops.
Qed.

Lemma list_to_fct_pr0: forall a l1 l2,
  list_to_fct (l2 ++ a :: l1) (length l2) = a.
Proof. ir. uf list_to_fct. induction l2. tv. app IHl2.
Qed.

Lemma list_to_fct_pr0B: forall a l1 l2,
  list_to_fctB (l2 ++ a :: l1) (length l2) = a.
Proof. ir. uf list_to_fctB. induction l2. tv. app IHl2.
Qed.

Lemma list_to_fct_pr: forall (A:Type) (f:nat->A) (u:A) n i,
  i<n -> nth i (fct_to_list f n) u = f i.
Proof. ir. cp (fct_to_list_length f n). ufi fct_to_list H0.
  rwi rev_length H0.
  uf fct_to_list. rww rev_nth. rw H0. clear H0.
  induction n. red in H. elim (le_Sn_O i). am.
  change (nth (S n - S i) (f n :: fct_to_list_rev f n) u = f i).
  assert (i<=n). red in H. autoa. nin (le_lt_or_eq _ _ H0).
  red in H1. wrr minus_Sn_m. app IHn. rw H1. wrr minus_n_n. simpl. ue.
Qed.

Lemma list_to_fct_pr1: forall f n i,
  i<n -> list_to_fct (fct_to_list f n) i = f i.
Proof. ir. uf list_to_fct. app list_to_fct_pr.
Qed.

Lemma list_to_fct_pr1B: forall f n i,
  i<n -> list_to_fctB (fct_to_list f n) i = f i.
Proof. ir. uf list_to_fctB. app list_to_fct_pr.
Qed.

Lemma list_to_fct_pr3: forall l2 l1,
  fct_to_list (list_to_fct (l2++l1)) (length l2) = l2.
Proof. ir. uf fct_to_list. cp (rev_involutive l2). wr H.
  set (l3:= rev l2) in *. clear H. apply (f_equal (rev (A:= nat))).
  rw rev_length. generalize l1. induction l3. tv.
  ir. assert (rev (a :: l3) ++ l0 = rev l3 ++ (a::l0)). simpl. rww app_ass.
  rw H. simpl. rw IHl3. wr (rev_length l3). rww list_to_fct_pr0.
Qed.

Lemma list_to_fct_pr4: forall l,
  fct_to_list (list_to_fct l) (length l) = l.
Proof. ir. cp (list_to_fct_pr3 l nil). wri app_nil_end H. am.
Qed.

Lemma list_to_fct_pr3B: forall l2 l1,
  fct_to_list (list_to_fctB (l2++l1)) (length l2) = l2.
Proof. ir. uf fct_to_list. cp (rev_involutive l2). wr H.
  set (l3:= rev l2) in *. clear H. apply (f_equal (rev (A:= Set))).
  rw rev_length. generalize l1. induction l3. tv.
  ir. assert (rev (a :: l3) ++ l0 = rev l3 ++ (a::l0)). simpl. rww app_ass.
  rw H. simpl. rw IHl3. wr (rev_length l3). rww list_to_fct_pr0B.
Qed.

Lemma list_to_fct_pr4B: forall l,
  fct_to_list (list_to_fctB l) (length l) = l.
Proof. ir. cp (list_to_fct_pr3B l nil). wri app_nil_end H. am.
Qed.

Lemma fct_to_list_unique: forall (A:Type) (f g: nat-> A) n,
  (forall i, i< n -> f i = g i) -> fct_to_list f n = fct_to_list g n.
Proof. intros A f g n. induction n. ir. tv. ir.
  uf fct_to_list. apply (f_equal (rev (A:= A))).
  simpl. rw (H n);try auto. assert (forall i : nat, i < n -> f i = g i).
  ir. app H. auto. cp (f_equal (rev (A:=A)) (IHn H0)).
  ufi fct_to_list H1. rwi rev_involutive H1. rwi rev_involutive H1. rww H1.
Qed.

Lemma app_nth3 : forall A (a:A),
  forall l' d n, n >= 1 -> nth n (a::l') d = nth (n-1) l' d.
Proof. ir. set (l:= a::nil). assert (a :: l' = l++l'). uf l. tv.
  rw H0. assert (length l=1). uf l. tv. wr H1. app app_nth2.
Qed.

Lemma fct_to_rev: forall (A:Type) (f:nat->A) n,
  rev (fct_to_list f n) = fct_to_list (fun i=> f(n-i-1)) n.
Proof. ir. apply list_extens with (u:=f 0). rw rev_length.
  do 2 rw fct_to_list_length. tv.
  rw rev_length. rw fct_to_list_length. ir.
  rw rev_nth. assert (length (fct_to_list f n) - S i =
  length (fct_to_list f n) - i -1). rw fct_to_list_length. app plus_minus.
  sy. app plus_minus. rw plus_assoc. wr (Sn_is_plus1 i). app le_plus_minus.
  rw H0. rw fct_to_list_length. rww list_to_fct_pr.
  cp (double_compl_nat H). rww list_to_fct_pr. app double_compl_ex.
  rww fct_to_list_length.
Qed.

Definition list_to_f (l: list nat):=
  BL (fun n => nat_to_B (list_to_fct l (cardinal_nat n)))
  (interval_co_0a (nat_to_B (length l))) Bnat.

Definition list_to_fB (l: list Set) E:=
  BL (fun n => list_to_fctB l (cardinal_nat n))
  (interval_co_0a (nat_to_B (length l))) E.

Lemma list_to_f_axioms: forall (l: list nat),
  transf_axioms (fun n => (nat_to_B (list_to_fct l (cardinal_nat n))))
  (interval_co_0a (nat_to_B (length l))) Bnat.
Proof. ir. red. ir. fprops.
Qed.

Lemma list_to_f_function: forall (l: list nat),
  is_function (list_to_f l).
Proof. ir. uf list_to_f. app bl_function. app list_to_f_axioms.
Qed.

Lemma list_to_f_W: forall (l: list nat) n,
  inc n (interval_co_0a (nat_to_B (length l))) ->
  W n (list_to_f l) = nat_to_B (list_to_fct l (cardinal_nat n)).
Proof. ir. uf list_to_f. rw bl_W. tv. app list_to_f_axioms. am.
Qed.

Lemma list_to_f_W1: forall (l: list nat) n,
  n < length l ->
  W (nat_to_B n) (list_to_f l) = nat_to_B (list_to_fct l n).
Proof. ir. cp (nat_to_B_pr1 n). set (m:=nat_to_B n). fold m in H0.
  wr H0. app list_to_f_W. srw. ee. uf m. fprops. uf m. bw. fprops.
Qed.

Lemma list_to_f_W2: forall (l: list nat) n,
  n < length l ->
  cardinal_nat(W (nat_to_B n) (list_to_f l)) = list_to_fct l n.
Proof. ir. rww list_to_f_W1. aw.
Qed.

Definition back_to_nat f n:=
  cardinal_nat (Yo (inc (nat_to_B n) (source f))
    (W (nat_to_B n) f) card_zero).

Lemma back_to_nat_pr: forall f n, inc (nat_to_B n) (source f) ->
  back_to_nat f n = cardinal_nat (W (nat_to_B n) f).
Proof. ir. uf back_to_nat. rw Y_if_rw. tv. am.
Qed.

Lemma back_to_nat_pr1: forall f n k,
  source f = (interval_co_0a (nat_to_B k)) ->
  n < k -> back_to_nat f n = cardinal_nat (W (nat_to_B n) f).
Proof. ir. app back_to_nat_pr. rw H. srw. ee. fprops. bw. fprops.
Qed.

Lemma back_to_nat_pr2: forall (l: list nat) n,
  n < (length l) -> back_to_nat (list_to_f l) n = list_to_fct l n.
Proof. ir.
  assert (source (list_to_f l) = (interval_co_0a (nat_to_B (length l)))).
  uf list_to_f. aw. rw (back_to_nat_pr1 H0 H).
  rww list_to_f_W1. aw.
Qed.

Lemma list_to_f_pr1: forall f n, is_function f -> target f = Bnat ->
  source f = (interval_co_0a (nat_to_B n)) ->
  f = list_to_f (fct_to_list (back_to_nat f) n).
Proof. ir. set (ll:=fct_to_list (back_to_nat f) n).
  assert (length ll = n). uf ll. rww fct_to_list_length.
  app function_exten. ee. app list_to_f_function.
  uf list_to_f. aw. ue. uf list_to_f. aw.
  ir. assert (Ha: inc (W x f) Bnat).
  wr H0. fprops. rwi H1 H3. cp (sub_interval_co_0a_Bnat H3).
  cp (nat_to_B_pr H4). srwi H3. wri H5 H3. bwi H3.
  wr H5. rww list_to_f_W1. uf ll. rww list_to_fct_pr1.
  rww (back_to_nat_pr1 H1 H3). rw H5. aw. rww H2. fprops.
Qed.

Lemma list_to_f_pr2: forall l,
  fct_to_list (back_to_nat (list_to_f l)) (length l) = l.
Proof. ir. wr list_to_fct_pr4. app fct_to_list_unique. ir.
  app back_to_nat_pr2.
Qed.

Inductive list_prop (A:Type) (q: A->Prop) : list A -> Prop :=
  | list_prop_nil: list_prop q nil
  | list_prop_cons: forall (a:A)(l:list A),
    q a -> list_prop q l -> list_prop q (a::l).

Lemma list_prop1: forall A (q: A->Prop), list_prop q nil.
Proof. ir. left. Qed.

Lemma list_prop2: forall A a b (q: A->Prop),
  q a -> (list_prop q b) = (list_prop q (a::b)).
Proof. ir. app iff_eq. ir. right;am. ir. inversion H0. am.
Qed.

Lemma list_prop3: forall A a b (q: A->Prop),
  ~ (q a) -> ~(list_prop q (a::b)).
Proof. ir. simpl. red. ir. inversion H0. contradiction.
Qed.

Lemma list_prop_app: forall A a b (q: A->Prop),
  (list_prop q a) -> (list_prop q b)
  -> (list_prop q (a++b)).
Proof. ir. induction a. simpl. am. simpl. inversion H. right. am. app IHa.
Qed.

Lemma list_prop_refine: forall A L (p q: A->Prop),
  (forall a, p a -> q a) -> list_prop p L -> list_prop q L.
Proof. ir. induction L. left. inversion H0. right. app H. app IHL.
Qed.

Lemma list_prop_nth: forall A (q: A->Prop) L u n,
  list_prop q L -> n < length L ->
  q (nth n L u).
Proof. intros A q L. induction L. ir. simpl in H0. elim (le_Sn_O n). am.
  intros u n rec. inversion rec. case n. ir. am.
  ir. simpl. app IHL. simpl in H3. autoa.
Qed.

Definition list_subset L E := list_prop (fun x => inc x E) L.

Fixpoint contraction (A B: Type) (L: list A) (f: A-> B->B) (v: B):B :=
  match L with | nil => v
    | a :: b => f a (contraction b f v) end.

Definition list_range l := contraction l (fun a b => tack_on b a) emptyset.

Lemma list_range_pr: forall L, list_subset L (list_range L).
Proof. ir. uf list_subset. induction L. left. right.
  uf list_range. simpl. fprops.
  assert (forall x, inc x (list_range L) -> inc x (tack_on (list_range L) a)).
  ir. fprops. app (list_prop_refine _ H IHL).
Qed.

Lemma list_range_pr1: forall L E, list_subset L E -> sub (list_range L) E.
Proof. ir. ufi list_subset H. induction L. uf list_range. simpl.
  ap emptyset_sub_any. uf list_range. simpl. inversion H.
  red. ir. rwi tack_on_inc H4. nin H4. app IHL. rww H4.
Qed.

Lemma list_to_fB_axioms: forall l E, list_subset l E ->
  transf_axioms (fun n => (list_to_fctB l (cardinal_nat n)))
  (interval_co_0a (nat_to_B (length l))) E.
Proof. ir. red. ir. wri (nat_to_B_pr (sub_interval_co_0a_Bnat H0)) H0.
  srwi H0. bwi H0. uf list_to_fctB. red in H.
  app list_prop_nth. fprops.
Qed.

Lemma list_to_fB_function: forall l E, list_subset l E ->
  is_function (list_to_fB l E).
Proof. ir. uf list_to_fB. app bl_function. app list_to_fB_axioms.
Qed.

Lemma list_to_fB_W: forall l E n, list_subset l E ->
  inc n (interval_co_0a (nat_to_B (length l))) ->
  W n (list_to_fB l E) = list_to_fctB l (cardinal_nat n).
Proof.
  ir. uf list_to_fB. rw bl_W. tv. app list_to_fB_axioms. am.
Qed.

Lemma list_to_fB_W1: forall l E n, list_subset l E ->
  n < length l ->
  W (nat_to_B n) (list_to_fB l E) = list_to_fctB l n.
Proof. ir. set (m:=nat_to_B n). wr (nat_to_B_pr1 n).
  app list_to_fB_W. srw. bw. fprops.
Qed.

Lemma partition_tack_on_intco: forall a, inc a Bnat ->
  partition_fam (variantLc (interval_co_0a a)
    (singleton a)) (interval_co_0a (succ a)).
Proof. ir. assert (Ha:is_finite_c a). wrr inc_Bnat.
  nin (interval_co_pr4 H). wr H0. app partition_tack_on.
Qed.

Lemma interval_co_0a_restr: forall a f, inc a Bnat ->
  (L (interval_co Bnat_order card_zero a) f
    = (restr (L (interval_co Bnat_order card_zero (succ a)) f)
      (interval_co_0a a))).
Proof. sy.
  assert (Ha:sub (interval_co_0a a)
    (domain (L (interval_co Bnat_order card_zero (succ a)) f))).
  bw. app interval_co_0a_increasing.
  app fgraph_exten. app restr_fgraph. gprops. gprops. rww restr_domain1. bw.
  gprops.
  rww restr_domain1.
  ir. bw. srwi H0. srw. nin H0. am. fprops. fprops. am. gprops. bwi Ha. am.
  gprops.
Qed.

Lemma length_app1: forall (A:Type) (a:A) l l',
  length l < length (l ++ a :: l').
Proof. ir. rw app_length.
  simpl. rw plus_comm. rw plus_Snm_nSm. red. app le_plus_r.
Qed.

Lemma length_app2: forall (A:Type) (a:A) l ,
  nat_to_B (length (l++a::nil)) = succ (nat_to_B (length l)).
Proof. ir. rw app_length. simpl. bw. rww plus_comm.
Qed.

Lemma list_to_f_cons0: forall a l l',
  W (nat_to_B (length l)) (list_to_f (l++ a:: l')) = nat_to_B a.
Proof. ir. rw list_to_f_W1. rww list_to_fct_pr0. app length_app1.
Qed.

Lemma list_to_f_cons1: forall a l l' n, n < length l ->
  W (nat_to_B n) (list_to_f (l ++ a :: l')) = W (nat_to_B n) (list_to_f l).
Proof. ir. rw list_to_f_W1. rww list_to_f_W1. uf list_to_fct.
  rww app_nth1. rw app_length. app lt_plus_trans.
Qed.

Lemma list_to_f_cons2: forall a l l',
  list_to_f l = restriction (list_to_f (l++ a :: l'))
               (interval_co_0a (nat_to_B (length l))).
Proof. ir. set (n:= nat_to_B(length l)).
  assert(sub (interval_co_0a n) (source (list_to_f (l ++ a :: l')))).
  uf list_to_f. aw. app interval_co_0a_increasing1. uf n. fprops. fprops.
  rw app_length. uf n. bw. app le_plus_l.
  assert (is_function (list_to_f (l ++ a :: l'))). app list_to_f_function.
  app function_exten. app list_to_f_function.
  app restriction_function. uf list_to_f. uf restriction. aw.
  uf list_to_f. uf restriction. aw. ir.
  ufi list_to_f H1. ufi restriction H1. awi H1.
  rww restriction_W. sy. simpl in H1.
  cp (nat_to_B_pr (sub_interval_co_0a_Bnat H1)). wr H2.
  app list_to_f_cons1. aw. srwi H1. am. fprops. wr H2. fprops.
Qed.

Lemma list_to_f_cons3: forall a l,
  list_to_f (l++a::nil) = tack_on_f (list_to_f l)
  (nat_to_B (length l)) (nat_to_B a).
Proof. ir. set (N:= nat_to_B (length l)).
  assert (Ha:is_function (list_to_f l)). app list_to_f_function.
  assert (Hb:inc N Bnat). uf N. fprops.
  cp (length_app2 a l).
  nin (interval_co_pr4 Hb).
  app function_exten. app list_to_f_function.
  app tack_on_function. uf list_to_f. uf restriction. aw.
  uf list_to_f. uf tack_on_f. aw. sy. rww H.
  uf list_to_f. uf tack_on_f. aw. sy. app tack_on_when_inc. fprops.
  ir. ufi list_to_f H2. awi H2. rwi H H2.
  ir. cp (nat_to_B_pr (sub_interval_co_0a_Bnat H2)).
  fold N in H2. wri H0 H2. rwi tack_on_inc H2. wr H3. nin H2. rww tack_on_W_in.
  app list_to_f_cons1. aw. srwi H2. am. am.
  wr H3. fprops. uf list_to_f. aw. rww H3. uf list_to_f. aw.
  assert (cardinal_nat N = length l). uf N. aw. rw H2. rw H4.
  rww list_to_f_cons0. rww tack_on_W_out. uf list_to_f. aw.
Qed.

Lemma list_subset_cons: forall a l l' E, list_subset l E -> inc a E ->
  list_subset l' E ->
  list_subset (l'++a::l) E.
Proof. induction l'. ir. simpl. right. am. am.
  ir. inversion H1. wr app_comm_cons. right. am. app IHl'.
Qed.

Hint Resolve list_subset_cons: fprops.

Lemma list_to_f_consB0: forall a l l' E,
  list_subset l E -> inc a E -> list_subset l' E ->
  W (nat_to_B (length l)) (list_to_fB (l++ a:: l') E) = a.
Proof. ir. rw list_to_fB_W1. rww list_to_fct_pr0B. fprops. app length_app1.
Qed.

Lemma list_to_f_consB1: forall a l l' n E, n< length l ->
  list_subset l E -> inc a E -> list_subset l' E ->
  W (nat_to_B n) (list_to_fB (l++ a :: l') E) = W (nat_to_B n) (list_to_fB l E).
Proof. ir. repeat rw list_to_fB_W1. uf list_to_fctB.
  rww app_nth1. am. am. fprops. rw app_length. app lt_plus_trans.
Qed.

Lemma list_to_f_consB2: forall a l l' E,
  list_subset l E -> inc a E -> list_subset l' E ->
  list_to_fB l E = restriction (list_to_fB (l++ a :: l') E)
               (interval_co_0a (nat_to_B (length l))).
Proof. ir. set (n:= nat_to_B(length l)).
  assert(sub (interval_co_0a n) (source (list_to_fB (l ++ a :: l') E))).
  uf list_to_fB. aw. app interval_co_0a_increasing1. uf n. fprops. fprops.
  rw app_length. uf n. bw. app le_plus_l.
  assert (is_function (list_to_fB (l ++ a :: l') E)).
    app list_to_fB_function. fprops.
  app function_exten. app list_to_fB_function.
  app restriction_function. uf list_to_fB. uf restriction. aw.
  uf list_to_fB. uf restriction. aw.
  ir. ufi list_to_fB H4. ufi restriction H4. awi H4.
  rww restriction_W. sy.
  cp (nat_to_B_pr (sub_interval_co_0a_Bnat H4)). wr H5.
  app list_to_f_consB1. aw. srwi H4. am. fprops. wr H5. fprops.
Qed.

Lemma list_to_f_consB3: forall a l E,
  list_subset l E -> inc a E ->
  list_to_fB (l++a::nil) E
  = tack_on_f (list_to_fB l E) (nat_to_B (length l)) a.
Proof. ir. ir. set (N:= nat_to_B (length l)).
  assert (Ha:is_function (list_to_fB l E)). app list_to_fB_function.
  assert (Hb:inc N Bnat). uf N. fprops.
  assert (Hc:list_subset nil E). left. fprops.
  cp (length_app2 a l).
  nin (interval_co_pr4 Hb).
  app function_exten. app list_to_fB_function. fprops.
  app tack_on_function. uf list_to_fB. aw. uf list_to_fB. uf tack_on_f. aw.
  fold N. rw H1. sy. am. uf list_to_fB. uf tack_on_f. aw.
  sy. app tack_on_when_inc. fprops. ir. ufi list_to_fB H4. awi H4.
  rwi H1 H4. cp (nat_to_B_pr (sub_interval_co_0a_Bnat H4)).
  fold N in H4. wri H2 H4. rwi tack_on_inc H4. wr H5. nin H4. rww tack_on_W_in.
  app list_to_f_consB1. aw. srwi H4. am. am.
  wr H5. fprops. uf list_to_fB. aw. uf list_to_fB. aw. wr H5. fprops.
  assert (cardinal_nat x = length l). rw H4. uf N. aw. rw H6.
  rww list_to_f_consB0. wr H6. rww H5. rw H4. rww tack_on_W_out.
  uf list_to_fB. aw.
Qed.

Definition fct_to_listB1 f n:=
  fct_to_list (fun n => W (nat_to_B n) f) n.

Definition fct_to_listB f := fct_to_listB1 f (cardinal_nat (source f)).
Definition iid_function f :=
  is_function f & exists n, source f = interval_co_0a (nat_to_B n).

Lemma fct_to_list_lengthB : forall f, iid_function f ->
  nat_to_B (length (fct_to_listB f)) = cardinal (source f).
Proof. ir. nin H. nin H0. uf fct_to_listB. rw H0. rw card_interval_c0_pr.
  uf fct_to_listB1. rw fct_to_list_length.
  rww cardinal_interval_co_0a1. fprops.
Qed.

Lemma list_to_fB_pr: forall l E, list_subset l E ->
  iid_function (list_to_fB l E).
Proof. ir. split. app list_to_fB_function. uf list_to_fB. aw.
  exists (length l). tv.
Qed.

Lemma fct_to_listB_pr0: forall f i,
  iid_function f -> i< cardinal_nat (source f) ->
  list_to_fctB (fct_to_listB f) i = W (nat_to_B i) f.
Proof. ir. uf fct_to_listB. uf fct_to_listB1. uf list_to_fctB.
  rww list_to_fct_pr.
Qed.

Lemma fct_to_listB_pr1: forall l E, list_subset l E ->
  fct_to_listB (list_to_fB l E) = l.
Proof. ir. uf fct_to_listB. uf list_to_fB. aw.
  rw card_interval_c0_pr. uf fct_to_listB1.
  set (l1:=fct_to_list (fun n => W (nat_to_B n) (list_to_fB l E)) (length l)).
  assert (length l1 = length l). uf l1. app fct_to_list_length.
  app (list_extens l1 l emptyset). ir. rwi H0 H1.
  uf l1. rw list_to_fct_pr. rww list_to_fB_W. aw. srw. bw. fprops. am.
Qed.

Lemma fct_to_listB_pr2: forall f, iid_function f ->
   list_subset (fct_to_listB f) (target f).
Proof. ir. red in H. ee. nin H0. uf fct_to_listB. rw H0.
  rw card_interval_c0_pr. uf fct_to_listB1.
  set (E:= target f).
  assert (forall n , n< x -> inc (W (nat_to_B n) f) E). ir. uf E.
  app inc_W_target. rw H0. srw. bw. fprops.
  clear H0.
  induction x. simpl. uf list_subset. uf fct_to_list. simpl. left.
  uf fct_to_list. simpl.
  app list_subset_cons. left. app H1. auto. app IHx. ir. app H1. autoa.
Qed.

Lemma fct_to_listB_pr3: forall f, iid_function f ->
  list_to_fB (fct_to_listB f) (target f) = f.
Proof. ir. cp (fct_to_listB_pr2 H). nin H. nin H1.
  assert (interval_co_0a (nat_to_B (length (fct_to_listB f))) = source f).
  uf fct_to_listB. uf fct_to_listB1. rw fct_to_list_length.
  rw H1. rww card_interval_c0_pr.
  app function_exten. app list_to_fB_function.
  uf list_to_fB. aw. uf list_to_fB. aw. ir. ufi list_to_fB H3. awi H3. ir.
  rww list_to_fB_W.
  uf fct_to_listB. uf fct_to_listB1. rwi H2 H3. rwi H1 H3.
  cp (sub_interval_co_0a_Bnat H3).
  rw list_to_fct_pr1B. aw. rw H1. rw card_interval_c0_pr.
  srwi H3. rww nat_B_lt. aw. fprops.
Qed.

Lemma induction_on_sum: forall a f, inc a Bnat ->
  (forall a, inc a Bnat -> is_cardinal (f a)) ->
  let iter := fun n=> cardinal_sum (L (interval_co_0a n)f)
    in card_plus (iter a) (f a) = (iter (succ a)).
Proof. ir. cp (partition_tack_on_intco H). uf iter.
  set (g:= (L (interval_co_0a (succ a)) f)).
  assert (fgraph g). uf g. gprops.
  assert (domain g = (interval_co_0a (succ a))). uf g. bw. wri H3 H1.
  rw (cardinal_sum_assoc H2 H1). bw. rw card_plus_pr0. bw.
  rw trivial_cardinal_sum3.
  rw interval_co_0a_restr. uf g. bw. app inc_a_interval_co_succ. am. am.
  rw H3. app inc_a_interval_co_succ. uf g. bw. app H0.
  app inc_a_interval_co_succ.
Qed.

Lemma induction_on_prod: forall a f, inc a Bnat ->
  (forall a, inc a Bnat -> is_cardinal (f a)) ->
  let iter := fun n=> cardinal_prod (L (interval_co_0a n ) f)
    in card_mult (iter a) (f a) = (iter (succ a)).
Proof. ir. cp (partition_tack_on_intco H). uf iter.
  set (g:= (L (interval_co_0a (succ a)) f)).
  assert (fgraph g). uf g. gprops.
  assert (domain g = (interval_co_0a (succ a))). uf g. bw. wri H3 H1.
  rw (cardinal_prod_assoc H2 H1). bw. rw card_mult_pr0. bw.
  rw trivial_cardinal_prod3.
  rw interval_co_0a_restr. uf g. bw. app inc_a_interval_co_succ. am. am.
  rw H3. app inc_a_interval_co_succ. uf g. bw. app H0.
  app inc_a_interval_co_succ.
Qed.

Lemma induction_on_sum1: forall f n,
  is_function f -> source f = interval_co_0a (succ n) -> inc n Bnat ->
  (forall a, inc a (source f) -> is_cardinal (W a f)) ->
  card_plus (cardinal_sum (graph (restriction f (interval_co_0a n))))
  (W n f) = cardinal_sum (graph f).
Proof. ir. cp (partition_tack_on_intco H1).
  set (g:= graph f). assert (fgraph g). uf g. fprops.
  assert (domain g = (interval_co_0a (succ n))). uf g. red in H. ee. wrr H6.
  wri H5 H3. rw (cardinal_sum_assoc H4 H3). bw. rw card_plus_pr0. bw.
  rw trivial_cardinal_sum3. uf restriction. aw. am.
  rw H5. app inc_a_interval_co_succ. uf g. ufi W H2. app H2.
  rw H0. app inc_a_interval_co_succ.
Qed.

Lemma induction_on_prod1: forall f n,
  is_function f -> source f = interval_co_0a (succ n) -> inc n Bnat ->
  (forall a, inc a (source f) -> is_cardinal (W a f)) ->
  card_mult (cardinal_prod (graph (restriction f (interval_co_0a n))))
  (W n f) = cardinal_prod (graph f).
Proof. ir. cp (partition_tack_on_intco H1).
  set (g:= graph f). assert (fgraph g). uf g. fprops.
  assert (domain g = (interval_co_0a (succ n))). uf g. red in H. ee. wrr H6.
  wri H5 H3. rw (cardinal_prod_assoc H4 H3). bw. rw card_mult_pr0. bw.
  rw trivial_cardinal_prod3. uf restriction. aw. am.
  rw H5. app inc_a_interval_co_succ. uf g. ufi W H2. app H2.
  rw H0. app inc_a_interval_co_succ.
Qed.

Lemma induction_on_sum2: forall a l,
  card_plus (cardinal_sum (graph (list_to_f l))) (nat_to_B a)
  = cardinal_sum (graph (list_to_f (l++a::nil))).
Proof. ir. set (f:= list_to_f (l++a::nil)).
  assert (is_function f). uf f. app list_to_f_function.
  set (n:= nat_to_B (length l)).
  assert (inc n Bnat). uf n. fprops.
  assert (source f = interval_co_0a (succ n)). uf f. uf list_to_f. aw.
  rww length_app2.
  assert (forall m, inc m (source f) -> is_cardinal (W m f)).
  ir. assert (inc (W m f) Bnat). uf f. rw list_to_f_W. fprops.
  ufi f H2. ufi list_to_f H2. awi H2. am. fprops.
  wr (induction_on_sum1 H H1 H0 H2). uf f. uf n. wr list_to_f_cons2.
  rww list_to_f_cons0.
Qed.

Lemma induction_on_prod2: forall a l,
  card_mult (cardinal_prod (graph (list_to_f l))) (nat_to_B a)
  = cardinal_prod (graph (list_to_f (l++a::nil))).
Proof. ir. set (f:= list_to_f (l++a::nil)).
  assert (is_function f). uf f. app list_to_f_function.
  set (n:= nat_to_B (length l)).
  assert (source f = interval_co_0a (succ n)). uf f. uf list_to_f.
  aw. rww length_app2.
  assert (inc n Bnat). uf n. fprops.
  assert (forall m, inc m (source f) -> is_cardinal (W m f)).
  ir. assert (inc (W m f) Bnat). uf f. rw list_to_f_W. fprops.
  ufi f H2. ufi list_to_f H2. awi H2. am. fprops.
  wr (induction_on_prod1 H H0 H1 H2). uf f. uf n. wr list_to_f_cons2.
  rww list_to_f_cons0.
Qed.

Lemma induction_on_sum0:
  cardinal_sum (graph (list_to_f nil)) = card_zero.
Proof. uf list_to_f. uf BL. aw. rww trivial_cardinal_sum. bw.
  ap emptyset_interval_00.
Qed.

Lemma induction_on_sum5: forall a,
  cardinal_sum (graph (list_to_f (a::nil))) = nat_to_B a.
Proof. ir. assert (a::nil = nil++ (a::nil)). tv. rw H.
  wr induction_on_sum2. rw induction_on_sum0. aw. fprops.
Qed.

Lemma induction_on_prod0:
  cardinal_prod (graph (list_to_f nil)) = card_one.
Proof. uf list_to_f. uf BL. aw.
  rww trivial_cardinal_prod. gprops. bw. ap emptyset_interval_00.
Qed.

Lemma induction_on_prod5: forall a,
  cardinal_prod (graph (list_to_f (a::nil))) = nat_to_B a.
Proof. ir. assert (a::nil = nil++ (a::nil)). tv. rw H.
  wr induction_on_prod2. rw induction_on_prod0. aw. fprops.
Qed.

Lemma induction_on_sum4: forall l l',
  card_plus (cardinal_sum (graph (list_to_f l)))
  (cardinal_sum (graph (list_to_f l')))
  = cardinal_sum (graph (list_to_f (l++l'))).
Proof. ir. wr (rev_involutive l). wr (rev_involutive l').
  set (m:= rev l). set (m':= rev l'). wr distr_rev.
  generalize m. induction m'. ir. simpl rev.
  rw induction_on_sum0.
  aw. uf cardinal_sum. fprops.
  simpl rev. ir. wr (induction_on_sum2 a (rev (m' ++ m0))). wr IHm'.
  wr card_plus_associative. rww induction_on_sum2.
Qed.

Lemma induction_on_prod4: forall l l',
  card_mult (cardinal_prod (graph (list_to_f l)))
  (cardinal_prod (graph (list_to_f l')))
  = cardinal_prod (graph (list_to_f (l++l'))).
Proof. ir. wr (rev_involutive l). wr (rev_involutive l').
  set (m:= rev l). set (m':= rev l'). wr distr_rev.
  generalize m. induction m'. ir. simpl rev. rw induction_on_prod0.
  aw. uf cardinal_prod. fprops.
  ir. simpl rev. wr (induction_on_prod2 a (rev (m' ++ m0))).
  wr IHm'. wr card_mult_associative. rww induction_on_prod2.
Qed.


Definition list_sum l := contraction l plus 0.
Definition list_prod l := contraction l mult 1.

Lemma list_sum_pr: forall l,
  nat_to_B (list_sum l) = cardinal_sum (graph (list_to_f l)).
Proof. ir. uf list_sum. induction l. rw induction_on_sum0. simpl. bw.
  assert (a::l = (a::nil) ++ l). tv. rw H. wr induction_on_sum4.
  rw induction_on_sum5. wr IHl. simpl. aw.
Qed.

Lemma list_prod_pr: forall l,
  nat_to_B (list_prod l) = cardinal_prod (graph (list_to_f l)).
Proof. ir. uf list_prod. induction l. rw induction_on_prod0. simpl. bw.
  app succ_zero.
  assert (a::l = (a::nil) ++ l). tv. rw H. wr induction_on_prod4.
  rw induction_on_prod5. wr IHl. simpl. aw.
Qed.

Lemma contraction_assoc: forall (A :Type) (L1 L2: list A)
  (f: A-> A->A) (v: A),
  (forall a b c, f a (f b c) = f (f a b) c) ->
  (forall a, f v a = a) ->
  (contraction (L1++L2) f v) = f (contraction L1 f v)(contraction L2 f v).
Proof. ir. induction L1. simpl. sy. app H0. simpl. rw IHL1. app H.
Qed.

Lemma list_sum_app: forall a b, list_sum (a++b) = (list_sum a)+ (list_sum b) .
Proof. ir. uf list_sum. app contraction_assoc. ir. rww plus_assoc.
Qed.

Lemma list_prod_app: forall a b,
  list_prod (a++b) = (list_prod a)* (list_prod b) .
Proof. ir. uf list_prod. app contraction_assoc. ir. rww mult_assoc.
  ir. auto with arith.
Qed.

Lemma list_sum_single: forall a, list_sum (a::nil) = a.
Proof. ir. uf list_sum. simpl. rww plus_0_r.
Qed.

Lemma list_sum_cons: forall a b, list_sum (a::b) = a + (list_sum b).
Proof. ir. tv.
Qed.

Lemma list_sum_consr: forall a b, list_sum (a++(b::nil)) = (list_sum a)+ b.
Proof. ir. rww list_sum_app. simpl. rww list_sum_single.
Qed.

Lemma list_prod_single: forall a, list_prod (a::nil) = a.
Proof. ir. uf list_prod. simpl. rww mult_1_r.
Qed.

Lemma list_prod_cons: forall a b, list_prod (a::b) = a*(list_prod b).
Proof. ir. tv.
Qed.
Lemma list_prod_consr: forall a b, list_prod (a++(b::nil)) = (list_prod a)* b.
Proof. ir. rww list_prod_app. simpl. rww list_prod_single.
Qed.

Definition fct_sum f n:= list_sum (fct_to_list f n).
Definition fct_prod f n:= list_prod(fct_to_list f n).

Lemma fct_sum0: forall f, fct_sum f 0 = 0.
Proof. ir. tv.
Qed.

Lemma fct_prod0: forall f, fct_prod f 0 = 1.
Proof. ir. tv.
Qed.

Lemma fct_sum_rec: forall f n, fct_sum f (S n) = (fct_sum f n) + (f n).
Proof. ir. uf fct_sum. uf fct_to_list. simpl. rw list_sum_app.
  rww list_sum_single.
Qed.

Lemma fct_prod_rec: forall f n, fct_prod f (S n) = (fct_prod f n) * (f n).
Proof. ir. uf fct_prod. uf fct_to_list. simpl. rw list_prod_app.
  rww list_prod_single.
Qed.

Lemma fct_sum_rec1: forall f n,
  fct_sum f (S n) = (f 0) + (fct_sum (fun i=> f (S i)) n).
Proof. ir. induction n. tv. rw fct_sum_rec. rw IHn. rw fct_sum_rec.
  rww plus_assoc.
Qed.

Lemma fct_prod_rec1: forall f n,
  fct_prod f (S n) = (f 0) * (fct_prod (fun i=> f (S i)) n).
Proof. ir. induction n. tv. rw fct_prod_rec. rw IHn. rw fct_prod_rec.
  rww mult_assoc.
Qed.

Lemma fct_sum_plus: forall f g n,
  (fct_sum f n) + (fct_sum g n) = fct_sum (fun i=> (f i) + (g i)) n.
Proof. ir. induction n. tv. repeat rw fct_sum_rec. wr IHn.
  rww plus_permute_2_in_4.
Qed.

Lemma fct_prod_mult: forall f g n,
  (fct_prod f n) * (fct_prod g n) =fct_prod (fun i=> (f i) * (g i)) n.
Proof. ir. induction n. tv. repeat rw fct_prod_rec. wr IHn.
  wr mult_assoc. wr mult_assoc. rw (mult_assoc (f n) (fct_prod g n) (g n)).
  rw (mult_comm (f n) (fct_prod g n)). wr mult_assoc. tv.
Qed.

Hint Rewrite fct_sum_rec fct_prod_rec : aw.

Lemma fct_sum_const: forall n m, fct_sum (fun _ => m) n = n *m.
Proof. ir. induction n. tv. aw. rw IHn. rw plus_comm. autoa.
Qed.

Lemma fct_prod_const: forall n m, fct_prod (fun _ => m) n = pow m n.
Proof. ir. induction n. tv. aw. rww IHn.
Qed.

Lemma list_sum_rev: forall l, list_sum l = list_sum (rev l).
Proof. induction l. tv. simpl. rw list_sum_consr. rw list_sum_cons.
  rww plus_comm. rww IHl.
Qed.

Lemma list_prod_rev: forall l, list_prod l = list_prod (rev l).
Proof. induction l. tv. simpl. rw list_prod_consr. rw list_prod_cons.
  rww mult_comm. rww IHl.
Qed.

Lemma fct_sum_rev: forall f n,
  fct_sum f n = fct_sum (fun i=> f(n-i-1)) n.
Proof. ir. uf fct_sum. wr fct_to_rev. rww list_sum_rev.
Qed.

Lemma fct_prod_rev: forall f n,
  fct_prod f n = fct_prod (fun i=> f(n-i-1)) n.
Proof. ir. uf fct_prod. wr fct_to_rev. rww list_prod_rev.
Qed.

Lemma l_to_fct: forall f n,
  BL (fun p => nat_to_B(f (cardinal_nat p))) (interval_co_0a (nat_to_B n))
  Bnat = list_to_f (fct_to_list f n).
Proof. ir.
  assert (transf_axioms (fun p => nat_to_B(f (cardinal_nat p)))
  (interval_co_0a (nat_to_B n)) Bnat). red. ir. fprops.
  app function_exten. app bl_function. app list_to_f_function.
  uf list_to_f. aw. rww fct_to_list_length. uf list_to_f. aw. aw.
  ir. rww bl_W. rww list_to_f_W. rww list_to_fct_pr1.
  cp (sub_interval_co_0a_Bnat H0).
  srwi H0. aw. fprops. rww fct_to_list_length.
Qed.

Lemma l_to_fct1: forall f n,
  L (interval_co_0a (nat_to_B n)) (fun p => nat_to_B(f (cardinal_nat p)))
  = graph (list_to_f (fct_to_list f n)).
Proof. ir. cp (l_to_fct f n). wr H. uf BL. aw.
Qed.

Lemma l_to_fct2: forall f n,
  L (interval_Bnat card_zero (nat_to_B n))
  (fun p => nat_to_B(f (cardinal_nat p)))
  = graph (list_to_f (fct_to_list f (S n))).
Proof. ir. wr (l_to_fct1 f (S n)).
  assert(predc (nat_to_B (S n)) = nat_to_B n). aw. ap predc_pr2. fprops.
  wr H. rww interval_co_0a_pr1. fprops. wr nat_B_0. red. ir.
  cp (nat_B_inj _ _ H0). symmetry in H1. elim (O_S n). am.
Qed.


Definition char_fun A B := BL (fun z=> Yo (inc z A) card_one card_zero)
  B (doubleton card_one card_zero).

Lemma char_fun_axioms: forall A B,
  transf_axioms (fun z=> Yo (inc z A) card_one card_zero)
  B (doubleton card_one card_zero).
Proof. ir. red. ir. ee. nin (inc_or_not c A). ir. rw Y_if_rw.
  fprops. am. ir. rw Y_if_not_rw. fprops. am.
Qed.

Lemma char_fun_function: forall A B, is_function (char_fun A B).
Proof. ir. uf char_fun. app bl_function. app char_fun_axioms. Qed.

Lemma char_fun_W:forall A B x,
  inc x B -> W x (char_fun A B) = Yo (inc x A) card_one card_zero.
Proof. ir. uf char_fun. aw. app char_fun_axioms.
Qed.

Lemma char_fun_W_cardinal:forall A B x,
  inc x B -> is_cardinal (W x (char_fun A B)).
Proof. ir. uf char_fun. aw. nin (p_or_not_p (inc x A))
  ; [rw Y_if_rw | rw Y_if_not_rw]; fprops. app char_fun_axioms.
Qed.

Lemma char_fun_W_a:forall A B x, sub A B -> inc x A ->
  W x (char_fun A B) = card_one.
Proof. ir. rw char_fun_W. rw Y_if_rw. tv. am. app H. Qed.

Lemma char_fun_W_b:forall A B x, sub A B -> inc x (complement B A) ->
  W x (char_fun A B) = card_zero.
Proof. ir. srwi H0. ee. rww char_fun_W. rww Y_if_not_rw. Qed.

Lemma chart_fun_injective: forall A A' B, sub A B -> sub A' B ->
  (A=A') = (char_fun A B = char_fun A' B).
Proof. ir. ap iff_eq. ir. rww H1. ir. set_extens.
  ex_middle. ir. assert (inc x (complement B A')).
  srw. ee. app H. am. cp (char_fun_W_a H H2).
  cp (char_fun_W_b H0 H4). elim card_one_not_zero. wr H5. wrr H6. rww H1.
  ex_middle. ir. assert (inc x (complement B A)).
  srw. ee. app H0. am. cp (char_fun_W_a H0 H2).
  cp (char_fun_W_b H H4). elim card_one_not_zero. wr H5. wrr H6. rww H1.
Qed.

Lemma char_fun_W_aa:forall A x, inc x A ->
  W x (char_fun A A) = card_one.
Proof. ir. rw char_fun_W. rw Y_if_rw. tv. am. am. Qed.

Lemma char_fun_W_bb:forall A x, inc x A ->
  W x (char_fun emptyset A) = card_zero.
Proof. ir. rww char_fun_W. rww Y_if_not_rw. red. app emptyset_pr. Qed.

Lemma char_fun_constant:forall A B, sub A B ->
  (forall x y, inc x B -> inc y B -> W x (char_fun A B) = W y (char_fun A B))
  -> (A=B \/ A = emptyset).
Proof. ir. nin (emptyset_dichot A). au. nin H1. left.
  app extensionality. red. ir.
  ex_middle. ir. assert (inc x (complement B A)).
  srw. ee. am. am. cp (char_fun_W_b H H4).
  cp (char_fun_W_a H H1). elim card_one_not_zero. wr H5. wrr H6. app H0. app H.
Qed.

Lemma char_fun_complement: forall A B x, sub A B -> inc x B ->
  W x (char_fun (complement B A) B)
  = card_sub card_one (W x (char_fun A B)).
Proof. ir. assert (Ha:sub (complement B A) B). app sub_complement.
  nin (inc_or_not x A). ir. rww char_fun_W_b.
  rw char_fun_W_a. sy. app minus_n_nC. fprops. am. am. srw.
  assert (inc x (complement B A)). srw. au.
  rww char_fun_W_a. rww char_fun_W_b. sy. app minus_n_0C. fprops.
Qed.

Lemma char_fun_inter: forall A A' B x, sub A B -> sub A' B -> inc x B ->
  W x (char_fun (intersection2 A A') B)
  = card_mult (W x (char_fun A B))(W x (char_fun A' B)).
Proof. ir. assert (Ha:sub (intersection2 A A') B). red. ir. app H. inter2tac.
  nin (inc_or_not x A). ir. rww (char_fun_W_a H H2).
  rw one_unit_prodl. nin (inc_or_not x A'). ir.
  rww char_fun_W_a. rww char_fun_W_a. app intersection2_inc. ir.
  rww char_fun_W_b. rww char_fun_W_b. srw. intuition. srw. ee. am. red. ir.
  elim H3. inter2tac. app char_fun_W_cardinal. ir.
  rww char_fun_W_b. rww char_fun_W_b. rw card_mult_commutative.
  rw zero_prod_absorbing. tv. srw. au. srw. ee. am. red. ir.
  elim H2. inter2tac.
Qed.

Lemma char_fun_union: forall A A' B x, sub A B -> sub A' B -> inc x B ->
  card_plus (W x (char_fun (intersection2 A A') B))
  (W x (char_fun (union2 A A') B) )
  = card_plus (W x (char_fun A B))(W x (char_fun A' B)).
Proof. ir. assert (Ha:sub (intersection2 A A') B). red. ir. app H. inter2tac.
  assert (Hb:sub (union2 A A') B). red. ir. nin (union2_or H2). app H. app H0.
  nin (p_or_not_p (inc x A)). rw (char_fun_W_a H H2).
  rw (char_fun_W_a Hb (union2_first A' H2)).
  nin (p_or_not_p (inc x A')). rw (char_fun_W_a H0 H3). rw char_fun_W_a. tv.
  am. app intersection2_inc. rw char_fun_W_b. rw char_fun_W_b.
  app card_plus_commutative. am. srw. intuition. am. srw. ee. am.
  red. ir. elim H3. inter2tac.
  assert (inc x (complement B A)). srw. intuition. rw (char_fun_W_b H H3).
  assert (inc x (complement B (intersection2 A A'))). srw. ee. am. red. ir.
  elim H2. inter2tac. rw (char_fun_W_b Ha H4).
  nin (p_or_not_p (inc x A')). rww char_fun_W_a. rww char_fun_W_a.
  app union2_second. rww char_fun_W_b. rww char_fun_W_b.
  srw. intuition. srw. ee. am. red. ir. nin (union2_or H6).
  elim H2. am. elim H5. am.
Qed.


Lemma least_int_prop0: forall p:nat->Prop,
  ~(p 0) -> (exists x, p x) -> (exists x, p (S x) & ~ p x).
Proof. ir. nin H0. set (q:= fun x => p (S x) & ~ p x).
  induction x. elim H. am. assert (~~ (ex q)). red. ir.
  ap H1. assert (forall x , ~ q x). ir. red. ir. apply H1. exists x0. am.
  assert (q x). uf q. ee. am. red. ir. app H1. app IHx. exists x. am.
  app excluded_middle.
Qed.

Lemma least_int_prop: forall prop:EP,
  (forall x, prop x -> inc x Bnat) -> (exists x, prop x) ->
  prop card_zero \/ (exists x, inc x Bnat & prop(succ x) & ~ prop x).
Proof. ir. set (X:=Zo Bnat prop). assert (sub X Bnat). uf X. app Z_sub.
  assert (nonempty X). nin H0. exists x. uf X. Ztac.
  nin (Bnat_wordered H1 H2). ufi X H3. Ztac. au. nin H3. ee. right. exists x.
  eee. ufi X H4. Ztac. am. dneg. uf X. Ztac.
Qed.

Lemma least_int_prop1: forall prop:EP,
  (forall x, prop x -> inc x Bnat) -> ~(prop card_zero) ->
  (exists x, prop x) -> (exists x, inc x Bnat &prop(succ x) & ~ prop x).
Proof. ir. cp (least_int_prop prop H H1). nin H2. elim H0. am. am.
Qed.

Lemma division_prop_nat: forall a b q r, 0 <>b ->
  (a=b*q+r & r<b) = (b*q <= a & a < b* (S q) & r = a - (b*q)).
Proof. ir. set (w:= b *q). assert (b * S q = w +b). uf w.
  rw Sn_is_plus1. rw mult_plus_distr_l. rww mult_1_r. rw H0.
  app iff_eq. ir. nin H1. rw H1. ee;auto with arith.
  ir. ee. rw H3. sy. app le_plus_minus_r. rwi (le_plus_minus _ _ H1) H2.
  wri H3 H2. app (plus_lt_reg_l _ _ _ H2).
Qed.

Lemma Ndivision_unique: forall a b q q' r r', 0 <> b ->
  a = b* q + r -> r < b -> a = b* q' + r' -> r'< b ->
  (q = q' & r = r').
Proof. ir. assert (a=b*q+r & r<b). intuition.
  assert (a=b*q'+r' & r'<b). intuition.
  rwi (division_prop_nat a q r H) H4. rwi (division_prop_nat a q' r' H) H5.
  assert (q = q'). ee. cp (le_lt_trans _ _ _ H4 H6).
  cp (le_lt_trans _ _ _ H5 H8). cp (mult_lt_reg_l _ _ H H10).
  cp (mult_lt_reg_l _ _ H H11). red in H12; red in H13.
  ap (le_antisym _ _ (le_S_n _ _ H12) (le_S_n _ _ H13)). ee. am.
  rw H10; rw H8; rww H6.
Qed.

Lemma Ndivision_existence: forall a b, 0 <> b ->
  exists q, exists r, (a = b* q + r & r < b).
Proof. ir. set (p:= fun q => a < b* q). assert (~ (p 0)). uf p. rw mult_comm.
  simpl. app lt_n_O. assert (ex p). exists (S a). uf p.
  apply lt_le_trans with (S a). red. auto.
  assert ( 1* (S a) <= b*(S a)). app mult_le_compat. ap (neq_O_lt _ H).
  rwi mult_1_l H1. am. nin ( least_int_prop0 p H0 H1).
  exists x. exists (a - b *x). rw division_prop_nat. ufi p H2. ee.
  nin (le_or_lt (b * x) a). am. elim H3. am. am. tv. am.
Qed.

Definition division_prop a b q r :=
  a = card_plus (card_mult b q) r & cardinal_lt r b.

Definition card_rem a b:=
  choose (fun r => inc r Bnat & exists q, inc q Bnat & division_prop a b q r).

Definition card_quo a b:=
  choose (fun q => inc q Bnat & exists r, inc r Bnat & division_prop a b q r).
Definition Bnat_divides b a := card_rem a b = card_zero.

Lemma division_result_integer:forall a b q r, inc a Bnat-> inc b Bnat ->
  b <> card_zero -> division_prop a b q r -> is_cardinal q ->
  (inc q Bnat & inc r Bnat).
Proof. ir. red in H2. nin H2. bwi H. rwi H2 H.
  assert (is_cardinal (card_mult b q)). fprops. red in H4. nin H4.
  bwi H0. assert (is_finite_c r). Bnat_tac.
  rwi card_plus_commutative H.
  cp (is_finite_in_sum H5 H). rwi card_mult_commutative H8.
  red in H0. ee. cp (is_finite_in_product H3 H0 H1 H8). bw. bw.
Qed.

Lemma division_prop_alt: forall a b q r, inc a Bnat-> inc b Bnat ->
  inc q Bnat-> inc r Bnat -> b <> card_zero ->
  division_prop a b q r = (cardinal_le (card_mult b q) a
  & cardinal_lt a (card_mult b (succ q))
  & r = card_sub a (card_mult b q)).
Proof. ir. uf division_prop. set (w:= card_mult b q).
  uf succ. rw card_mult_commutative.
  rw cardinal_distrib_prod_sum2. rw card_mult_commutative.
  rw one_unit_prodl.
  assert (inc w Bnat). uf w. fprops.
  app iff_eq. ir. ee. rw H5. app sum_increasing3. fprops. fprops.
  rw H5. app finite_sum2_lt. uf w. fprops. app card_sub_pr2.
  sy; rw card_plus_commutative; am.
  ir. ee. rw H7. sy. app card_sub_pr. fold w in H6.
  rwi cardinal_lt_pr H6. nin H6. ee. cp (card_sub_pr H H4 H5).
  wri H10 H9. rwi card_plus_associative H9. wri H7 H9.
  rww cardinal_lt_pr. exists x. ee. am. am.
  rwi (card_plus_commutative x w) H9. wri card_plus_associative H9.
  ap (plus_simplifiable_left H4 (Bnat_stable_plus H6 H2) H0 H9).
  am. fprops. fprops.
Qed.

Lemma division_unique:forall a b q r q' r', inc a Bnat-> inc b Bnat ->
  inc q Bnat-> inc r Bnat -> inc q' Bnat-> inc r' Bnat -> b <> card_zero ->
  division_prop a b q r -> division_prop a b q' r' ->
  (q = q' & r =r').
Proof. ir. rwi (division_prop_alt H H0 H1 H2 H5) H6.
  rwi (division_prop_alt H H0 H3 H4 H5) H7. assert (q = q'). ee.
  cp (cardinal_le_lt_trans H6 H8). cp (cardinal_le_lt_trans H7 H10).
  cp (Bnat_mult_lt_simplifiable H0 H1 (inc_succ_Bnat H3) H5 H12).
  cp (Bnat_mult_lt_simplifiable H0 H3 (inc_succ_Bnat H1) H5 H13).
  bwi H1. bwi H3. srwi H14. srwi H15. co_tac. am. am.
  ee. am. rw H12; rw H10; rw H8. app refl_equal.
Qed.

Lemma division_exists:forall a b, inc a Bnat-> inc b Bnat ->
  b <> card_zero -> exists q, exists r,
    (inc q Bnat & inc r Bnat & division_prop a b q r).
Proof. ir. set (pp:= fun q => inc q Bnat & cardinal_lt a
  (card_mult b q)). assert (forall x, pp x -> inc x Bnat).
  uf pp. ir. ee; am. assert (~ (pp card_zero)). uf pp. red. ir. ee.
  rwi zero_prod_absorbing H4. app (zero_smallest1 H4).
  assert (exists x, pp x). uf pp. exists (succ a). ee. fprops.
  assert (is_finite_c a). fprops. assert (cardinal_le a a).
  red in H4. ee. fprops. srwi H5. wri lt_is_le_succ H5.
  cp (Bnat_is_cardinal H0). assert (is_cardinal (succ a)). uf succ. fprops.
  cp (product_increasing3 H7 H6 H1). rw card_mult_commutative. co_tac. am.
  cp (least_int_prop1 pp H2 H3 H4). ufi pp H5. nin H5. ee.
  assert (cardinal_le (card_mult b x) a).
  nin (Bnat_total_order (Bnat_stable_mult H0 H5) H). red in H9; ee; am.
  elim H7. ee. am. red in H9. ee. red in H9. ee. red; ee; am.
  cp (card_sub_pr0 H (Bnat_stable_mult H0 H5) H9).
  set (r:= (card_sub a (card_mult b x))) in *. ee.
  exists x. exists r. ee. am. uf r. fprops. rww division_prop_alt. ee. am.
  am. tv. uf r; fprops.
Qed.

Lemma Bnat_division: forall a b, inc a Bnat-> inc b Bnat -> b <> card_zero ->
  (inc (card_rem a b) Bnat & (inc (card_quo a b) Bnat) &
    (division_prop a b (card_quo a b) (card_rem a b))).
Proof. ir. cp (division_exists H H0 H1). nin H2. nin H2.
  assert (inc (card_rem a b)Bnat & exists q,
    inc q Bnat &division_prop a b q (card_rem a b)).
  uf card_rem. app choose_pr. exists x0. ee. am. exists x. ee; am.
  assert (inc (card_quo a b) Bnat & exists r, inc r Bnat &
    division_prop a b (card_quo a b) r).
  uf card_quo. app choose_pr. exists x. ee. am. exists x0. ee; am.
  ee. am. am. nin H6. nin H5. ee.
  cp (division_unique H H0 H2 H7 H6 H3 H1 H8 H10).
  cp (division_unique H H0 H2 H7 H4 H5 H1 H8 H9). ee. wr H12. wr H14. am.
Qed.

Definition Nquo a b :=
  cardinal_nat (card_quo (nat_to_B a)
    (Yo (b = 0) card_one (nat_to_B b))).
Definition Nrem a b :=
  cardinal_nat (card_rem (nat_to_B a)
    (Yo (b = 0) card_one (nat_to_B b))).

Definition Ndivides b a:= 0 <> b & Nrem a b = 0.

Lemma inc_quotient_bnat:forall a b, inc a Bnat-> inc b Bnat ->
  b <> card_zero -> inc (card_quo a b) Bnat.
Proof. ir. nin (Bnat_division H H0 H1). nin H3. am.
Qed.

Lemma inc_remainder_bnat:forall a b, inc a Bnat-> inc b Bnat ->
  b <> card_zero -> inc (card_rem a b) Bnat.
Proof. ir. cp (Bnat_division H H0 H1). ee; am. Qed.

Hint Resolve inc_quotient_bnat inc_remainder_bnat: fprops.

Lemma Ndivision_exists: forall a b, 0 <> b ->
  (a = b* (Nquo a b) + (Nrem a b) & (Nrem a b < b)).
Proof. ir. uf Nquo. uf Nrem. rw Y_if_not_rw.
  assert ((nat_to_B b) <> card_zero). red. ir.
  wri nat_B_0 H0. elim H. sy. app (nat_B_inj _ _ H0).
  cp (inc_nat_to_B a). cp (inc_nat_to_B b). nin (Bnat_division H1 H2 H0).
  nin H4. red in H5. bwi H5. ee. ap nat_B_inj. aw. aw. intuition.
Qed.

Lemma Ndivision_pr: forall a b q r, 0 <> b ->
  a = b* q + r -> r < b -> (q = Nquo a b & r = Nrem a b).
Proof. ir. nin (Ndivision_exists a H). app (Ndivision_unique _ _ H H0 H1 H2 H3).
Qed.

Lemma Ndivision_pr_q: forall a b q r, 0 <> b ->
  a = b* q + r -> r < b -> q = Nquo a b.
Proof. ir. nin (Ndivision_pr q H H0 H1). am.
Qed.

Lemma Ndivision_pr_r: forall a b q r, 0 <> b ->
  a = b* q + r -> r < b -> r = Nrem a b.
Proof. ir. nin (Ndivision_pr q H H0 H1). am.
Qed.

Lemma nat_B_division: forall a b, 0 <> b ->
  (nat_to_B (Nquo a b) = card_quo (nat_to_B a) (nat_to_B b) &
    nat_to_B (Nrem a b) = card_rem (nat_to_B a) (nat_to_B b)).
Proof. ir. uf Nquo. uf Nrem. assert (nat_to_B b <> card_zero).
  wr nat_B_0. red;ir. elim H. sy. app nat_B_inj.
  rw Y_if_not_rw. aw. split;tv.
  app inc_remainder_bnat. fprops. fprops.
  app inc_quotient_bnat. fprops. fprops. intuition.
Qed.

Lemma nat_B_quo: forall a b, 0 <> b ->
  nat_to_B (Nquo a b) = card_quo (nat_to_B a) (nat_to_B b).
Proof. ir. nin (nat_B_division a H). am.
Qed.

Lemma nat_B_rem: forall a b, 0 <> b ->
  nat_to_B (Nrem a b) = card_rem (nat_to_B a) (nat_to_B b).
Proof. ir. nin (nat_B_division a H). am.
Qed.

Lemma Ndivides_pr: forall a b,
  Ndivides b a -> a = b * (Nquo a b).
Proof. ir. red in H. ee. nin (Ndivision_exists a H). rwi H0 H1.
  rwi plus_comm H1. simpl in H1. am.
Qed.

Lemma Ndivides_pr1: forall a b, 0 <> b-> Ndivides b (b *a).
Proof. ir. red. split. am. sy.
  assert (b * a = b * a + 0). rww plus_comm.
  assert (0 < b). app neq_O_lt. nin (Ndivision_pr _ H H0 H1). am.
Qed.

Lemma Ndivides_pr2: forall a b q, 0 <> b ->
  a = b * q -> q = Nquo a b.
Proof. ir. nin (Ndivides_pr1 q H). nin (Ndivision_exists (b*q) H).
  rwi H2 H3. rwi plus_comm H3. simpl in H3. rw H0.
  app (mult_simplifiable_leftN _ _ H H3).
Qed.

Lemma one_divides_all: forall a, Ndivides 1 a.
Proof. ir. assert (0 <> 1). auto. assert (a = 1 *a). auto with arith.
  rw H0. app Ndivides_pr1.
Qed.
Lemma quotient_by_one: forall a, Nquo a 1 = a.
Proof. ir. sy. app Ndivides_pr2. auto. auto with arith.
Qed.

Lemma Ndivides_pr3: forall a b q,
  Ndivides b a -> q = Nquo a b -> a = b * q.
Proof. ir. cp (Ndivides_pr H). rww H0.
Qed.

Lemma Ndivides_pr4: forall b q, 0 <> b ->
  Nquo (b * q) b = q.
Proof. ir. sy. app Ndivides_pr2.
Qed.

Lemma Ndivision_itself: forall a, 0 <> a ->
  (Ndivides a a & Nquo a a = 1).
Proof. ir. assert (a = a *1 ). auto with arith. ee. cp (Ndivides_pr1 1 H).
  wri H0 H1. am. cp (Ndivides_pr4 1 H). wri H0 H1. am.
Qed.

Lemma Ndivides_itself: forall a, 0 <> a -> Ndivides a a.
Proof. ir. nin (Ndivision_itself H). am.
Qed.

Lemma Nquo_itself: forall a, 0 <> a ->
  Nquo a a = 1.
Proof. ir. nin (Ndivision_itself H). am.
Qed.

Lemma Ndivision_of_zero: forall a, 0 <> a ->
  (Ndivides a 0 & Nquo 0 a = 0).
Proof. ir. pose (mult_n_O a). split. rw e. ap (Ndivides_pr1 0 H).
  rw e. rww (Ndivides_pr4 0 H).
Qed.

Lemma Ndivides_trans: forall a b a', Ndivides a a'-> Ndivides b a
  -> Ndivides b a'.
Proof. ir. cp (Ndivides_pr H). cp (Ndivides_pr H0).
  rwi H2 H1. wri mult_assoc H1. nin H0. rw H1. app Ndivides_pr1.
Qed.

Lemma Ndivides_trans1: forall a b a', Ndivides a a'-> Ndivides b a
  -> Nquo a' b = (Nquo a' a) *(Nquo a b).
Proof. ir. cp (Ndivides_pr H). cp (Ndivides_pr H0). rwi H2 H1.
  wri mult_assoc H1. nin H0. cp (Ndivides_pr2 _ H0 H1). wr H4. wr H2.
  rww mult_comm.
Qed.

Lemma Ndivides_trans2: forall a b c,
  Ndivides b a-> Ndivides b (a *c).
Proof. ir. nin (p_or_not_p (0=a)). wr H0. simpl.
  nin H. nin (Ndivision_of_zero H). am. cp (Ndivides_pr1 c H0).
  app (Ndivides_trans H1 H).
Qed.

Lemma non_zero_mult: forall a b, 0 <> a -> 0 <> b -> 0 <> (a*b) .
Proof. ir. assert (0*b < a * b). app mult_lt_compat_r. app neq_O_lt.
  app neq_O_lt. simpl in H1. ap lt_O_neq. am.
Qed.

Lemma Nquo_simplify: forall a b c, 0 <> b -> 0 <> c ->
  Nquo (a * c) (b * c) = Nquo a b.
Proof. ir. nin (Ndivision_exists a H).
  assert ( a * c = b * c * Nquo a b + (Nrem a b) *c).
  rw (mult_comm b c). wr mult_assoc. rw (mult_comm c (b * Nquo a b)).
  wr mult_plus_distr_r. wrr H1.
  assert (Nrem a b * c < b * c). app mult_lt_compat_r. app neq_O_lt.
  nin (Ndivision_pr _ (non_zero_mult H H0) H3 H4). sy; am.
Qed.

Lemma divides_and_sum: forall a a' b, Ndivides b a -> Ndivides b a'
  -> (Ndivides b (a + a') &
    Nquo (a + a') b = (Nquo a b) + (Nquo a' b)).
Proof. ir. cp (Ndivides_pr H). cp (Ndivides_pr H0).
  assert (a + a' = b * (Nquo a b + Nquo a' b)).
  rw mult_plus_distr_l. wr H1; wrr H2. rw H3. nin H. split.
  app Ndivides_pr1. sy. app Ndivides_pr2.
Qed.

Lemma distrib_prod2_sub: forall a b c, inc a Bnat -> inc b Bnat -> inc c Bnat
  -> cardinal_le c b ->
  card_mult a (card_sub b c) = card_sub (card_mult a b) (card_mult a c).
Proof. ir. app card_sub_pr2. fprops. fprops.
  wr cardinal_distrib_prod_sum3. rw card_plus_commutative. rww card_sub_pr.
Qed.

Lemma distrib_prod2_subN: forall a b c, c<= b->
  a * (b-c) = (a*b) - (a*c).
Proof. ir. app plus_minus. wr mult_plus_distr_l.
  wrr (le_plus_minus _ _ H).
Qed.

Lemma divides_and_difference: forall a a' b, a' <= a ->
  Ndivides b a -> Ndivides b a'
  -> (Ndivides b (a -a') &
    (Nquo a' b) <= (Nquo a b) &
    Nquo (a - a') b = (Nquo a b) - (Nquo a' b)).
Proof. ir. cp (Ndivides_pr H0). cp (Ndivides_pr H1).
  rwi H2 H; rwi H3 H. nin H0. nin (nonzero_suc H0).
  rwi H5 H. cp (mult_S_le_reg_l _ _ _ H). wri H5 H6.
  cp (distrib_prod2_subN b H6). wri H3 H7. wri H2 H7. wr H7.
  ee. app Ndivides_pr1. am. sy. app Ndivides_pr2.
Qed.


Lemma b_power_k_large: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_lt card_one b -> a <> card_zero -> exists k,
    inc k Bnat & cardinal_le (card_pow b k) a
    & cardinal_lt a (card_pow b (succ k)).
Proof. ir. set (prop:= fun k=> inc k Bnat & cardinal_lt a (card_pow b k)).
  assert (forall x, prop x -> inc x Bnat). uf prop. ir. ee. am.
  assert (~(prop card_zero)). uf prop. red. ir. ee. rwi power_x_0 H5.
  cp (Bnat_is_cardinal H). cp (one_small_cardinal H6 H2).
  red in H5. ee. elim H8. co_tac.
  assert (exists x, prop x).
  uf prop. exists a. ee. am. app lt_a_power_b_a.
  nin (least_int_prop1 _ H3 H4 H5). ufi prop H6. ee. exists x. ee. am.
  cp (Bnat_stable_pow H0 H6). nin (Bnat_total_order H10 H). red in H11; ee; am.
  elim H8. ee. am. red in H11. ee. red in H11; red;ee;am. am.
Qed.

Lemma lt_a_power_b_aN: forall a b, 1< b -> a < pow b a.
Proof. ir. induction a. rw power_x_0N. auto. red in IHa.
  apply le_lt_trans with (pow b a). am. simpl. set (t:= pow b a).
  wr (mult_1_l t). wr mult_assoc. rw (mult_1_l (t* b)).
  rw (mult_comm t b). app mult_lt_compat_r. red. ir.
  apply le_trans with (S a). auto with arith. am.
Qed.

Definition is_expansion f b k :=
  inc b Bnat & inc k Bnat & cardinal_lt card_one b &
  fgraph f & domain f = interval_co_0a k &
  forall i, inc i (domain f) -> cardinal_lt (V i f) b.

Definition expansion_value f b :=
  cardinal_sum (L (domain f) (fun i=> card_mult (V i f) (card_pow b i))).

Lemma is_expansion_prop0: forall f b k i,
  is_expansion f b k -> (inc i (domain f)) = cardinal_lt i k.
Proof. ir. red in H. ee. rw H3. srw.
Qed.

Lemma is_expansion_prop1: forall f b k i,
  is_expansion f b k -> cardinal_lt i k -> inc (V i f) Bnat.
Proof. ir. assert (inc i (domain f)). rww (is_expansion_prop0 i H).
  red in H. ee. cp (H6 _ H1). nin H7. Bnat_tac.
Qed.

Lemma is_expansion_prop2: forall f b k, is_expansion f b k ->
  finite_int_fam (L (domain f) (fun i=> card_mult (V i f) (card_pow b i))).
Proof. ir. red. bw. split. gprops. split. ir. bw. wr inc_Bnat.
  app Bnat_stable_mult.
  rwi (is_expansion_prop0 i H) H0.
  app (is_expansion_prop1 H H0). red in H. ee. rwi H4 H0.
  cp (sub_interval_co_0a_Bnat H0). fprops.
  red. red in H. ee. ee. rw H3. rw cardinal_interval_co_0a1. fprops. am.
Qed.

Lemma is_expansion_prop3: forall f b k, is_expansion f b k ->
  inc (expansion_value f b) Bnat.
Proof. ir. uf expansion_value. app finite_sum_finite.
  app (is_expansion_prop2 H).
Qed.

Lemma is_expansion_prop4: forall f b k, is_cardinal k ->
  is_expansion f b (succ k) -> inc k Bnat.
Proof. ir. red in H0. ee. bwi H1. bw. rww is_finite_succ.
Qed.

Lemma is_expansion_prop5: forall f b k, is_cardinal k ->
  is_expansion f b (succ k) ->
  is_expansion (restr f (interval_co_0a k)) b k.
Proof. ir. cp (is_expansion_prop4 H H0). cp (interval_co_0a_increasing H1).
  red in H0. ee.
  assert (domain (restr f (interval_co_0a k)) = interval_co_0a k).
  rww restr_domain1. ue.
  red. ee. am. am. am. fprops. am. rw H8. ir. bw. app H7. ue. ue.
Qed.

Lemma is_expansion_prop6: forall f b k, is_cardinal k ->
  is_expansion f b (succ k) -> inc (V k f) Bnat.
Proof. ir. cp (is_expansion_prop4 H H0).
  app(is_expansion_prop1 (i:=k) H0). srw. fprops. fprops.
Qed.

Lemma is_expansion_prop7: forall f b k, is_cardinal k ->
  is_expansion f b (succ k) ->
  (expansion_value f b) =
  card_plus (expansion_value (restr f (interval_co_0a k)) b)
     (card_mult (V k f) (card_pow b k)).
Proof. ir. cp (is_expansion_prop4 H H0).
  set (g:= fun i=> card_mult (V i f) (card_pow b i)).
  assert (forall a, inc a Bnat -> is_cardinal (g a)). ir. uf g. fprops.
  cp (induction_on_sum g H1 H2). uf expansion_value. sy. simpl in H3.
  fold g. red in H0. ee.
  assert (card_mult (V k f) (card_pow b k) = g k). tv. rw H9. wri H7 H3.
  assert (L (domain (restr f (interval_co_0a k)))
           (fun i =>
            card_mult (V i (restr f (interval_co_0a k))) (card_pow b i))=
           (L (interval_co_0a k) g)).
  cp (interval_co_0a_increasing H1). sy.
  app L_exten1. rw restr_domain1. tv. am. rw H7. am. ir.
  bw. ue. ue.
Qed.

Lemma is_expansion_prop8: forall f b k x,
  let g:= L (interval_co_0a (succ k)) (fun i=> Yo (i=k) x (V i f)) in
    is_expansion f b k ->
    inc x Bnat -> cardinal_lt x b ->
    (is_expansion g b (succ k) &
      expansion_value g b = card_plus (expansion_value f b)
      (card_mult (card_pow b k) x)).
Proof. ir. assert (is_expansion g b (succ k)). red in H. ee. red. uf g. bw.
  ee. fprops. fprops. am.
  gprops. tv. ir. bw. nin (equal_or_not i k). rw H8. rw Y_if_rw. am. tv.
  rww Y_if_not_rw. app H6. rw H5. nin (interval_co_pr4 H2). wri H9 H7.
  rwi tack_on_inc H7. nin H7. am. elim H8; am. split. am.
  red in H. ee. assert (is_cardinal k). fprops.
  rw (is_expansion_prop7 H8 H2).
  assert (restr g (interval_co_0a k)= f). uf g. sy.
  cp (interval_co_0a_increasing H3).
  app fgraph_exten. app restr_fgraph. gprops. rw restr_domain1. am.
  gprops. bw. ir. rwi H6 H10.
  bw. rw Y_if_not_rw. tv. srwi H10.
  nin H10. am. am. app H9. gprops. rw H9.
  assert (card_mult (V k g) (card_pow b k) = card_mult (card_pow b k) x).
  rww card_mult_commutative. uf g. bw. rww Y_if_rw.
  app inc_a_interval_co_succ. rww H10.
Qed.

Lemma is_expansion_prop9: forall f b k, is_expansion f b k ->
  cardinal_lt (expansion_value f b) (card_pow b k).
Proof. ir. set (p:= fun n => forall f, is_expansion f b n ->
  cardinal_lt (expansion_value f b) (card_pow b n)).
  app (cardinal_c_induction_v p). uf p. ir. rw power_x_0.
  uf expansion_value. red in H0. ee. rw H4. rw emptyset_interval_00.
  rw trivial_cardinal_sum. app zero_lt_one. bw.
  ir. uf p. ir.
  assert (is_cardinal n). fprops. rw (is_expansion_prop7 H3 H2).
  cp (is_expansion_prop5 H3 H2). cp (H1 _ H4). rww pow_succ.
  set (a0:= expansion_value (restr f0 (interval_co_0a n)) b) in *.
  set (b0:= card_pow b n) in *.
  assert (cardinal_lt (V n f0) b). red in H2. ee. app H10. rw H9.
  app inc_a_interval_co_succ. cp (is_expansion_prop6 H3 H2). red in H. ee.
  wri (lt_n_succ_le H7 H) H6.
  assert (inc b0 Bnat). uf b0. fprops.
  ufi succ H6. assert (cardinal_le b0 b0). uf b0. fprops.
  cp (product_increasing2 H6 H14). rwi cardinal_distrib_prod_sum2 H15.
  rwi one_unit_prodl H15. rw card_plus_commutative.
  set (b1:= card_mult (V n f0) b0) in *. assert (inc b1 Bnat). uf b1. fprops.
  assert (cardinal_lt (card_plus b1 a0) (card_plus b1 b0)).
  app finite_sum2_lt. uf a0. app (is_expansion_prop3 H4). fprops.
  rw card_mult_commutative. co_tac. nin H14. am.
  red in H2; ee; am. red in H; ee; am.
Qed.

Lemma is_expansion_prop10: forall f b k, is_cardinal k ->
  is_expansion f b (succ k) ->
  division_prop (expansion_value f b) (card_pow b k) (V k f)
  (expansion_value (restr f (interval_co_0a k)) b).
Proof. ir. red. split. rw card_plus_commutative. rw card_mult_commutative.
  app is_expansion_prop7. app is_expansion_prop9.
  app is_expansion_prop5.
Qed.

Lemma is_expansion_unique: forall f g b k,
  is_expansion f b k -> is_expansion g b k ->
  expansion_value f b = expansion_value g b -> f = g.
Proof. ir. set (p:= fun n => forall f g, is_expansion f b n ->
  is_expansion g b n -> expansion_value f b = expansion_value g b->
  f = g). cut (p k). uf p. ir. app H2.
  ap (cardinal_c_induction_v p). uf p. uf is_expansion. rw emptyset_interval_00.
  ir. ee. app fgraph_exten. rww H8. rw H13. ir.
  elim (emptyset_pr H15). ir. uf p. ir.
  assert (is_cardinal n). fprops. cp (is_expansion_prop10 H7 H5).
  cp (is_expansion_prop10 H7 H4). rwi H6 H9. nin H. ee.
  cp (is_expansion_prop5 H7 H4). cp (is_expansion_prop5 H7 H5).
  assert (inc (expansion_value g0 b) Bnat). app (is_expansion_prop3 H5).
  assert (inc (card_pow b n) Bnat). fprops.
  assert (inc (V n g0) Bnat). app (is_expansion_prop6 H7 H5).
  assert (inc (expansion_value (restr g0 (interval_co_0a n)) b) Bnat).
  app (is_expansion_prop3 H16).
  assert (inc (V n f0) Bnat). app (is_expansion_prop6 H7 H4).
  assert (inc (expansion_value (restr f0 (interval_co_0a n)) b) Bnat).
  app (is_expansion_prop3 H15).
  assert (card_pow b n <> card_zero).
  assert (cardinal_lt card_zero b). app le_one_not_zero. nin H11; am.
  nin (non_zero_apowb H23 H7). intuition.
  cp (division_unique H17 H18 H19 H20 H21 H22 H23 H8 H9). nin H24.
  assert (restr g0 (interval_co_0a n) = restr f0 (interval_co_0a n)). app H3.
  red in H4; red in H5. ee. app fgraph_exten. rww H30.
  ir. rwi H35 H37. nin (equal_or_not x n). rw H38. sy; am.
  assert (inc x (interval_co_0a n)). srw.
  srwi H37. red; split;am. fprops. fprops.
  assert (V x (restr g0 (interval_co_0a n)) = V x g0). bw.
  rw H30. app interval_co_0a_increasing.
  assert (V x (restr f0 (interval_co_0a n)) = V x f0). bw.
  rw H35. app interval_co_0a_increasing. wr H40; wr H41; rww H26.
  red in H; ee. am.
Qed.

Lemma is_expansion_exists1: forall a b k,
  inc b Bnat -> cardinal_lt card_one b -> inc k Bnat ->
  inc a Bnat -> cardinal_lt a (card_pow b k) ->
  exists f, (is_expansion f b k & expansion_value f b = a).
Proof. ir.
  set (p:= fun k => forall a, inc a Bnat -> cardinal_lt a (card_pow b k) ->
    exists f, is_expansion f b k & expansion_value f b = a).
  app (cardinal_c_induction_v p). uf p. rw power_x_0. ir.
  exists (L emptyset (fun _ => card_zero)). split. red. ee. am. fprops. am.
  gprops. bw. wrr emptyset_interval_00. bw. ir. elim (emptyset_pr H6).
  uf expansion_value. bw. rw trivial_cardinal_sum.
  nin (equal_or_not a0 card_zero). ir. sy; am.
  assert (is_cardinal a0). fprops. cp (one_small_cardinal H7 H6).
  nin H5. elim H9. rww (cardinal_antisymmetry1 H5 H8). bw. ir. red. ir.
  set (b0:= (card_pow b n)). assert (inc b0 Bnat). uf b0. fprops.
  assert(b0 <> card_zero). assert (cardinal_lt card_zero b).
  assert (cardinal_le card_zero card_one).
  app zero_smallest. fprops. co_tac.
  assert (is_cardinal n). fprops. nin (non_zero_apowb H9 H10). intuition.
  cp (division_exists H6 H8 H9). nin H10. nin H10. ee. red in H12. ee.
  ufi b0 H13. nin (H5 _ H11 H13). ee.
  assert (cardinal_lt (card_mult b0 x) (card_mult b0 b)).
  assert (cardinal_le (card_mult b0 x) a0). rw H12. app sum_increasing3.
  assert (inc (card_mult b0 x) Bnat). fprops. fprops. fprops.
  uf b0. wr pow_succ. fold b0. co_tac. am. am.
  cp (Bnat_mult_lt_simplifiable H8 H10 H H9 H16).
  nin (is_expansion_prop8 H14 H10 H17).
  set (f:= (L (interval_co_0a (succ n))(fun i => Yo (i = n) x (V i x1)))) in *.
  exists f. ee. am. rwi H15 H19. rw H12. rw H19. rw card_plus_commutative.
  fold b0. rw card_mult_commutative. app refl_equal.
Qed.

Lemma is_expansion_exists: forall a b, inc a Bnat -> inc b Bnat ->
  cardinal_lt card_one b -> exists k, exists f,
    (is_expansion f b k & expansion_value f b = a).
Proof. ir. exists a. app is_expansion_exists1. app lt_a_power_b_a.
Qed.

Lemma is_expansion_prop11: forall f g b k, is_cardinal k ->
  is_expansion f b (succ k) -> is_expansion g b (succ k) ->
  cardinal_lt (V k f) (V k g) ->
  cardinal_lt (expansion_value f b) (expansion_value g b).
Proof. ir. rw (is_expansion_prop7 H H0). rw (is_expansion_prop7 H H1).
  cp (is_expansion_prop5 H H0). cp (is_expansion_prop5 H H1).
  cp (is_expansion_prop9 H3). cp (is_expansion_prop9 H4).
  set (u:=(expansion_value (restr f (interval_co_0a k)) b)) in *.
  set (v:=(expansion_value (restr g (interval_co_0a k)) b)) in *.
  cp (is_expansion_prop4 H H0).
  cp (is_expansion_prop6 H H0). cp (is_expansion_prop6 H H1).
  wri (lt_n_succ_le H8 H9) H2. ufi succ H2. red in H0. ee.
  set (b0:= card_pow b k) in *. assert (inc b0 Bnat). uf b0. fprops.
  assert (cardinal_le b0 b0). uf b0. fprops.
  cp (product_increasing2 H2 H16). rwi cardinal_distrib_prod_sum2 H17.
  rwi one_unit_prodl H17. rw card_plus_commutative.
  set (t:= card_mult (V k f) b0) in *.
  assert (cardinal_lt (card_plus t u) (card_plus t b0)).
  assert (inc t Bnat). uf t. fprops. app finite_sum2_lt. uf u.
  ap (is_expansion_prop3 H3). fprops.
  set (t':= card_mult (V k g) b0) in *. assert (inc t' Bnat). uf t'. fprops.
  assert (cardinal_le t' (card_plus v t')). rw card_plus_commutative.
  app sum_increasing3. fprops. nin H6. nin H6. am.
  cp (cardinal_le_transitive H17 H20). co_tac. fprops.
Qed.

Definition function_on_nat f :=
  fun m => nat_to_B (f (cardinal_nat m)).

Lemma inc_function_on_nat_Bnat : forall f n,
  inc (function_on_nat f n) Bnat.
Proof. ir. uf function_on_nat. fprops. Qed.

Lemma function_on_nat_pr : forall f n,
  cardinal_nat(function_on_nat f n) = f (cardinal_nat n).
Proof. ir. uf function_on_nat. aw.
Qed.

Lemma function_on_nat_pr1 : forall f n,
  function_on_nat f (nat_to_B n) = nat_to_B (f n).
Proof. ir. uf function_on_nat. aw.
Qed.


Lemma mutually_disjoint_prop1: forall f, is_function f ->
  (forall i j y, inc i (source f) -> inc j (source f) ->
    inc y (W i f) -> inc y (W j f) -> i=j) ->
  mutually_disjoint (graph f).
Proof. ir. assert (domain (graph f) = source f). red in H. ee; sy; am.
  wri H1 H0. ufi W H0. app mutually_disjoint_prop.
Qed.

Theorem shepherd_principle: forall f c, is_function f ->
  (forall x, inc x (target f) -> cardinal (inv_image_by_fun f (singleton x))=c)
  -> cardinal (source f) = card_mult (cardinal (target f)) c.
Proof. ir.
  set (pa := L (target f) (fun z=> (inv_image_by_fun f (singleton z)))).
  assert (unionb pa = (source f)). set_extens. ufi pa H1. rwi unionb_rw H1.
  nin H1. ee. bwi H1. bwi H2. ufi inv_image_by_fun H2. awi H2. nin H2.
  ee. rwi (singleton_eq H2) H3. graph_tac. fprops.
  uf pa. srw. bw. exists (W x f). cp (inc_W_target H H1).
  ee. am. uf inv_image_by_fun. bw. aw. exists (W x f). ee. fprops.
  red. app W_pr3.
  assert (mutually_disjoint pa). app mutually_disjoint_prop. uf pa. bw. ir.
  bwi H4. bwi H5. ufi inv_image_by_fun H4. ufi inv_image_by_fun H5.
  awi H4. awi H5. nin H4; nin H5. ee. awi H4; awi H5. wr H4; wr H5.
  nin H. nin H8. ap (fgraph_pr H8 H7 H6). am. am.
  assert (fgraph pa). uf pa. gprops.
  cp (cardinal_sum_pr H3).
  assert (L (domain pa) (fun a => cardinal (V a pa)) =
    (L (domain pa) (fun a => c))). app L_exten1. uf pa. ir.
  bwi H5. bw. app H0. rwi H5 H4.
  assert (L (domain pa) (fun _ : Set => c) = cst_graph (domain pa) c). tv.
  rwi H6 H4. rwi sum_of_same1 H4. clear H5. clear H6.
  assert (card_mult c (domain pa) = card_mult (cardinal (target f)) c).
  rw card_mult_commutative. uf pa. bw. rw card_mult_pr1. rw card_mult_pr1.
  aw. app equipotent_product. fprops. fprops. wr H5. wr H4. aw. wr H1.
  uf disjoint_union. app equipotent_disjoint_union. uf pa. gprops.
  uf disjoint_union_fam. gprops. uf disjoint_union_fam. bw. ir.
  uf disjoint_union_fam. bw. fprops. app disjoint_union_disjoint.
Qed.

Fixpoint factorial (n:nat) : nat :=
  match n with
  | 0 => 1
  | S p => (factorial p) * S p
  end.

Lemma factorial0: factorial 0 = 1.
Proof. ir. tv. Qed.

Lemma factorial1: factorial 1 = 1.
Proof. ir. tv. Qed.

Lemma factorial2: factorial 2 = 2.
Proof. ir. tv. Qed.

Lemma factorial_succ: forall n, factorial (S n) = (factorial n) * (S n).
Proof. ir. tv. Qed.

Lemma factorial_nonzero: forall n, 0 <> factorial n.
Proof. ir. induction n. simpl. auto. simpl. app non_zero_mult.
Qed.

Hint Resolve factorial_nonzero: fprops.

Lemma factorial_prop: forall f, f 0 = 1 ->
  (forall n, f (S n) = (f n) * (S n)) ->
  forall x, f x = factorial x.
Proof. ir. induction x. simpl. am. rw H0. rw IHx. tv.
Qed.

Lemma factorial_prop1: forall n, factorial n = fct_prod S n.
Proof. ir. induction n. rww fct_prod0. simpl. rw IHn. rww fct_prod_rec.
Qed.

Lemma quotient_of_factorials: forall a b, b <= a ->
  Ndivides (factorial b) (factorial a).
Proof. ir. cp (le_plus_minus _ _ H). rw H0. set (n:= a-b).
  induction n. rw plus_comm. simpl. app Ndivides_itself. fprops.
  simpl. wr plus_n_Sm. simpl. app Ndivides_trans2.
Qed.

Lemma quotient_of_factorials1: forall a b, b <= a ->
  Ndivides (factorial (a - b)) (factorial a).
Proof. ir. app quotient_of_factorials. app le_minus.
Qed.

Lemma tack_on_nat: forall a b, is_finite_set (tack_on a b) ->
  ~ (inc b a) -> cardinal_nat (tack_on a b) = S (cardinal_nat a).
Proof. ir. cp H. red in H. rwii cardinal_succ_pr H. wri succ_cardinal H.
  wri is_finite_succ H. wr (cardinal_nat_cardinal a).
  wr (cardinal_nat_cardinal (tack_on a b)).
  app nat_B_inj. aw. rww cardinal_succ_pr.
  rw succ_cardinal. tv. bw. bw. fprops.
Qed.

Lemma cardinal_complement_image: forall f, injective f ->
  is_finite_set (target f) ->
  (cardinal_le (cardinal (source f)) (cardinal (target f)) &
    cardinal (complement (target f) (image_of_fun f)) =
    card_sub (cardinal (target f)) (cardinal (source f))).
Proof. uf is_finite_set. intro f. set (a:= cardinal (source f)).
  set (b:= cardinal (target f)). ir. ee. red. ee. uf a. fprops. uf b. fprops.
  uf a. uf b. wr cardinal_le2. rw cardinal_le1. exists f. ee. am. tv. tv.
  set (E1:= image_of_fun f). set (E2:= complement (target f) E1).
  assert (a = cardinal E1). uf a. rw cardinal_equipotent.
  cp (restriction_to_image_bijective H). red. exists (restriction_to_image f).
  ee. am. uf restriction_to_image. uf restriction2. aw.
  uf restriction_to_image. uf restriction2. aw.
  assert (sub E1 (target f)). uf E1. uf image_of_fun.
  red in H. ee. red in H. ee. rw H4. rw image_by_graph_domain. red in H.
  fprops. fprops. assert (union2 E1 E2 = target f).
  set_extens. nin (union2_or H3). app H2. ufi E2 H4. srwi H4.
  ee; am. nin (p_or_not_p (inc x E1)). inter2tac. app union2_second.
  uf E2. srw. ee; am.
  assert (disjoint E1 E2). uf E2. app disjoint_complement.
  assert (equipotent E1 a). rw H1. fprops. assert (equipotent E2 (cardinal E2)).
  fprops. cp (card_plus_pr1 H4 H5 H6). rwi H3 H7. fold b in H7.
  rwi H7 H0. app plus_minusC. bw.
  rwi card_plus_commutative H0. app (is_finite_in_sum (a:= cardinal E2)).
  fprops. rw H1. fprops. bw. app (is_finite_in_sum (a:=a)). fprops.
Qed.

Definition number_of_injections b a :=
  Nquo (factorial a) (factorial (a - b)).

Lemma number_of_injections_pr: forall a b, b <= a ->
  (number_of_injections b a) * (factorial (a - b))
  = factorial a.
Proof. ir. uf number_of_injections. sy. rw mult_comm.
  app Ndivides_pr3. app quotient_of_factorials1.
Qed.

Lemma number_of_injections_rec: forall a b, b<a ->
  (number_of_injections b a) * (a - b) =
  number_of_injections (S b) a.
Proof. ir. cp (number_of_injections_pr (lt_le_weak _ _ H)).
  set (A:= number_of_injections b a) in *.
  cp (number_of_injections_pr H).
  set (B:= number_of_injections (S b) a) in *.
  assert (a - b = S (a - S b)). red in H. cp (le_plus_minus _ _ H).
  sy. ap plus_minus. wrr plus_Snm_nSm. rwi H2 H0. simpl in H0.
  wri H2 H0. wri H1 H0. rwi (mult_comm (factorial (a - S b)) (a - b)) H0.
  rwi mult_assoc H0.
  app (mult_simplifiable_rightN _ _ (factorial_nonzero (a - S b)) H0).
Qed.

Lemma number_of_injections_base: forall a,
  number_of_injections 0 a = 1.
Proof. ir. uf number_of_injections. simpl. wr minus_n_O.
  ap (Nquo_itself (factorial_nonzero a)).
Qed.

Definition set_of_injections E F :=
  Zo (set_of_functions E F)(fun z=> injective z).

Lemma number_of_injections_prop: forall E F n m,
  cardinal E = nat_to_B n -> cardinal F = nat_to_B m -> n <= m ->
  cardinal (set_of_injections E F) = nat_to_B(number_of_injections n m).
Proof. ir. set (s:= fun E => cardinal_le (cardinal E) (cardinal F) ->
  cardinal(set_of_injections E F) =
  nat_to_B(number_of_injections (cardinal_nat E) m)).
  assert (Ha:is_finite_set E). red. wr inc_Bnat. rw H. fprops.
  assert(Hb: cardinal_le (cardinal E) (cardinal F)). rw H; rw H0. bw.
  cp (nat_to_B_pr1 n). wr H2. wr H. rw cardinal_nat_cardinal.
  app (finite_set_induction0 s). uf s. ir. rw cardinal_nat_emptyset.
  rw number_of_injections_base. set (f:= BL (fun z=> emptyset) emptyset F).
  assert (is_function f). uf f. app bl_function. red. ir.
  elim (emptyset_pr H4). assert (injective f). red. ee. am. uf f. simpl.
  ir. awi H5. elim (emptyset_pr H5).
  assert (inc f (set_of_functions (source f) (target f))). aw. eee.
  assert (source f = emptyset). uf f. aw. rwi H7 H6.
  assert (target f = F). uf f; aw. rwi H8 H6.
  assert (set_of_injections emptyset F= singleton f). set_extens.
  ufi set_of_injections H9. Ztac.
  rw (small_set_of_functions_source H10 H6). fprops.
  rww (singleton_eq H9). uf set_of_injections. Ztac. rw H9.
  rw cardinal_singleton. rww nat_B_1.
  clear H2. uf s. ir. assert (inc (cardinal F) Bnat). rw H0. fprops.
  assert (is_finite_c (cardinal (tack_on a b))). bwi H5. Bnat_tac.
  rw (tack_on_nat H6 H3).
  assert (Hd: succ a = succ (cardinal a)). sy. app succ_cardinal.
  assert (He:is_cardinal (cardinal a)). fprops.
  assert (Hc:cardinal (tack_on a b) = succ a). rww cardinal_succ_pr.
  rwi Hc H6. rwi Hd H6. wrii is_finite_succ H6. rwi Hc H4.
  rwi Hd H4. cp H5; bwi H7. srwi H4;tv. clear H7.
  assert (cardinal_nat (cardinal a) < cardinal_nat (cardinal F)). aw. bw.
  rwi cardinal_nat_cardinal H7. rwi H0 H7. rwi nat_to_B_pr1 H7.
  wrr number_of_injections_rec. rw nat_B_mult. nin H4. wr (H2 H4).
  set (G2:= set_of_injections (tack_on a b) F).
  set (G1:= set_of_injections a F).
  set (rf:=BL (fun z=> restriction z a) G2 G1).
  assert (source rf = G2). uf rf. aw. wr H9.
  assert (target rf = G1). uf rf. aw. wr H10. clear H10.
  assert (transf_axioms (fun z=> restriction z a) G2 G1).
  uf G1. uf G2. red. ir. ufi set_of_injections H10. Ztac. awi H11. clear H10.
  ee. uf set_of_injections. Ztac. set (t:= restriction c a).
  assert (is_function t). uf t. app restriction_function. ue.
  assert (target t = F). uf t. uf restriction. aw.
  assert (source t = a). uf t. uf restriction. aw. aw. eee.
  red. ee. app restriction_function. ue.
  assert (source (restriction c a) = a). uf restriction. aw.
  rw H14. assert (sub a (source c)). ue. ir.
  do 2 rwii restriction_W H18. nin H12. app H19. app H15. app H15.
  assert (is_function rf). uf rf. app bl_function. app shepherd_principle.
  ir. set(K:= inv_image_by_fun rf (singleton x)).
  ir. ufi rf H12. awi H12. ufi G1 H12. ufi set_of_injections H12.
  Ztac. clear H12. awi H13. ee.
  assert (is_finite_set (target x)). rw H15. red. rww H0. fprops.
  cp (cardinal_complement_image H14 H16). ee. rwi H15 H18. rwi H0 H18.
  rwi H13 H18.
  set (C:= complement F (image_of_fun x)) in *.
  cut (cardinal K = cardinal C). ir. wr (cardinal_nat_cardinal a).
  rw H19. rw H18. aw. bw. clear H18; clear H17.
  set (val:= BL (fun z => W b z) K C).
  assert (transf_axioms (fun z => W b z) K C). red.
  uf C; uf K. ir. ufi inv_image_by_fun H17. awi H17. nin H17.
  ee. rwi (singleton_eq H17) H18. cp (W_pr H11 H18). ufi rf H19.
  rwi bl_W H19. wri H19 H15. ufi restriction H15. awi H15.
  cp (inc_pr1graph_source H11 H18). ufi rf H20. awi H20. ufi G2 H20.
  ufi set_of_injections H20. Ztac. awi H21. ee. srw. ee. wr H24.
  app inc_W_target. ue. red. ir. ufi image_of_fun H25. awi H25. nin H25. ee.
  cp (W_pr H12 H26). assert (W x1 x = W x1 c). wr H19.
  rww restriction_W. ue. ue. rwi H28 H27. nin H22. elim H3. rwi H13 H25.
  cut (b = x1). ir. ue. sy. app H29. ue. ue. fprops.
  cp (inc_pr1graph_source H11 H18). ufi rf H20. awi H20. am.
  assert (is_function val). uf val. app bl_function. rw cardinal_equipotent.
  exists val. assert (source val = K). uf val. aw.
  assert (target val = C). uf val. aw. eee. uf val. app bl_bijective.
  ir. ufi K H21. ufi K H22. ufi inv_image_by_fun H21. ufi inv_image_by_fun H22.
  awi H21. awi H22. nin H21. nin H22. ee. awi H21. awi H22. rwi H21 H25.
  rwi H22 H24. cp (inc_pr1graph_source H11 H25).
  cp (inc_pr1graph_source H11 H24). ufi rf H26. awi H26. ufi rf H27. awi H27.
  assert (Hu:= H26); assert (Hv:= H27). ufi G2 H26; ufi G2 H27.
  ufi set_of_injections H26. ufi set_of_injections H27.
  Ztac. clear H27; Ztac. awi H28. awi H27. ee.
  app function_exten. ue. ue. rw H31. ir. rwi tack_on_inc H35. nin H35.
  cp (W_pr H11 H25). cp (W_pr H11 H24). ufi rf H36. ufi rf H37.
  rwii bl_W H36. rwii bl_W H37.
  transitivity (W x2 x). wr H36. rww restriction_W. rw H31. fprops.
  wr H37. rww restriction_W. rw H33. fprops. rww H35.
  ir. ufi C H21. uf K. srwi H21. nin H21. set (f:= tack_on_f x b y).
  assert (is_function f). uf f. app tack_on_function. ue.
  assert (source f = tack_on a b). uf f. uf tack_on_f. aw. ue.
  assert (~ (inc b (source x))). ue.
  assert (target f = F). uf f. uf tack_on_f. aw. rw H15. app tack_on_when_inc.
  assert (injective f). red. ee. am. rw H24. ir.
  rwi tack_on_inc H27; rwi tack_on_inc H28. nin H27; nin H28.
  ufi f H29. rwii tack_on_W_in H29. rwii tack_on_W_in H29. red in H14; ee.
  app H30. ue. ue. ue. ue. rwi H28 H29.
  ufi f H29. rwii tack_on_W_in H29. rwii tack_on_W_out H29. elim H22.
  wr H29. uf image_of_fun. aw. exists x0. ee. ue. app W_pr3. ue. ue.
  rwi H27 H29. ufi f H29. rwii tack_on_W_out H29. rwii tack_on_W_in H29.
  elim H22. rw H29. uf image_of_fun. aw. exists y0. ee. ue. app W_pr3.
  ue. ue. ue.
  assert (Hbb: inc f G2). uf G2. uf set_of_injections. Ztac. aw. eee.
  assert (restriction f a = x). app function_exten.
  app restriction_function. ue. ue. uf restriction. aw.
  uf restriction. aw. ue. ir. ufi restriction H28. awi H28.
  rww restriction_W. uf f. rww tack_on_W_in. ue. ue.
  assert (inc f (inv_image_by_fun rf (singleton x))).
  uf inv_image_by_fun. aw. exists x. ee. fprops. assert (W f rf = x). uf rf.
  rww bl_W. wr H29. app W_pr3. ue.
  exists f. ee. am. aw. uf f. rww tack_on_W_out.
Qed.

Lemma number_of_permutations: forall E n, cardinal E = nat_to_B n ->
  cardinal (set_of_permutations E) = nat_to_B (factorial n).
Proof. ir. assert (set_of_permutations E = set_of_injections E E).
  uf set_of_permutations. uf set_of_injections.
  set_extens. Ztac. nin H2. am. Ztac. awi H1. ee.
  app bijective_if_same_finite_c_inj. rw H3; ue. ue.
  red. rw H. fprops.
  rw H0. rw (number_of_injections_prop H H (le_n n)).
  uf number_of_injections. wr minus_n_n. simpl. rww quotient_by_one.
Qed.

Definition partition_with_pi_elements p E f :=
  is_function f & source f = domain p &
  (forall i, inc i (domain p) -> cardinal (W i f) = V i p) &
  partition_fam (graph f) E.

Definition set_of_partitions p E :=
  Zo(set_of_functions (domain p) (powerset E))
    (fun z=> partition_with_pi_elements p E z).

Lemma equipotent_restriction: forall f x,
  sub x (source f) -> bijective f ->
  equipotent x (image_by_fun f x).
Proof. ir. exists (restriction1 f x). split.
  app restriction1_bijective. nin H0; am. uf restriction1. aw. au.
Qed.

Lemma number_of_partitions1: forall p E,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  nonempty(set_of_partitions p E).
Proof. ir. ufi cardinal_sum H0. rwi cardinal_equipotent H0. nin H0.
  ee. ufi disjoint_union H1. ufi disjoint_union_fam H1.
  set (f:= BL(fun i => image_by_fun x (product (V i p) (singleton i)))
    (domain p) (powerset E)). assert (is_function x). fct_tac.
  assert (Hb:is_graph p). red in H. ee. red in H; ee. am.
  assert (Ha: forall i, inc i (domain p) ->sub (product (V i p)(singleton i))
    (source x)). red. ir. rw H1. rw unionb_rw. bw. exists i. ee. am. bw.
  assert (transf_axioms (fun i => image_by_fun x (product (V i p)(singleton i))) (domain p) (powerset E)). red. ir. ap powerset_inc. red. ir. awi H5.
  nin H5. ee. wr H6. wr H2. app inc_W_target. app (Ha _ H4). am. app Ha.
  assert (is_function f). uf f. app bl_function.
  assert (partition_with_pi_elements p E f). red. ee. am. uf f; aw. ir. uf f.
  rww bl_W. red in H. ee. cp (H7 _ H6).
  assert (V i p = cardinal (V i p)). assert (is_cardinal (V i p)). fprops.
  sy. fprops. rw H10. rw cardinal_equipotent. wr H10.
  eqtrans (product (V i p) (singleton i)). eqsym. app equipotent_restriction.
  app Ha. eqsym. fprops. red. ee. fprops. app mutually_disjoint_prop1.
  uf f. aw. ir. awi H8. awi H9. nin H8; nin H9. ee. assert (x0=x1).
  nin H0. ee. nin H0. ee. app H13. app (Ha _ H6). app (Ha _ H7). ue.
  wri H12 H9. awi H8; awi H9. ee. wr H16. wrr H14.
  am. app Ha. am. am. am. app Ha. am. am.
  wr H2. uf f. uf BL. aw. simpl. set_extens. srwi H6. nin H6. nin H6. bwi H6.
  bwi H7. awi H7. nin H7. ee. wr H8. app inc_W_target. app (Ha _ H6). am.
  app Ha. am. red in H0. ee. cp (surjective_pr2 H7 H6). nin H8. ee.
  rwi H1 H8. srwi H8. bwi H8. nin H8. ee. srw. bw.
  exists x2. ee. am. bw. bwi H10. aw. exists x1. ee. am. am. app Ha. am.
  exists f. uf set_of_partitions. Ztac. aw. eee. uf f. aw. uf f. aw.
Qed.

Lemma number_of_partitions2: forall E p f g,
  inc g (set_of_permutations E) ->
  (transf_axioms (fun i => image_by_fun g (W i f))
    (domain p) (powerset E)).
Proof. ir. ufi set_of_permutations H. Ztac. awi H0. ee.
  red. ir. uf image_by_fun. app powerset_inc. wr H3. aw. red. ir.
  awi H5. nin H5. nin H5. graph_tac.
Qed.

Definition set_of_partitions_aux p E f g:=
  BL (fun i => image_by_fun g (W i f))
    (domain p) (powerset E).

Lemma number_of_partitions3: forall p E f g,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  partition_with_pi_elements p E f -> inc g (set_of_permutations E) ->
  inc (set_of_partitions_aux p E f g) (set_of_partitions p E).
Proof. ir. uf set_of_partitions_aux. cp (number_of_partitions2 (p:=p) f H2).
  ufi set_of_permutations H2. Ztac. clear H2. awi H4. ee.
  assert (Ha:forall u, inc u (domain p) -> sub (W u f) (source g)).
  ir. rw H4. red. ir. red in H1. ee. red in H11; ee. wr H13. srw.
  exists u. aw. ee. ue. am.
  assert (Hb:is_graph p). red in H; ee. fprops.
  set (h:=BL (fun i => image_by_fun g (W i f))(domain p) (powerset E)).
  assert (is_function h). uf h. app bl_function. uf set_of_partitions. Ztac.
  aw. ee. am. uf h. aw. uf h. aw.
  red. ee. am. uf h. aw. ir. uf h. sy. red in H1.
  ee. aw. wr H10. aw. app equipotent_restriction. app Ha. awi H11. am.
  awi H8. am. am.
  red. ee. fprops. app mutually_disjoint_prop1. uf h. aw. ir.
  awi H10. awi H11. nin H10. nin H11. ee. assert (x = x0). nin H5. nin H5.
  app H15. app (Ha _ H8). app (Ha _ H9). ue. red in H1; ee. red in H17.
  ee. red in H18. ee.
  assert (domain (graph f) = source f). red in H1; ee; sy;am. rwi H20 H18.
  rwi H15 H18. nin (H18 _ _ H8 H9). am. red in H21.
  empty_tac1 x0. app intersection2_inc. ue.
  am. app Ha. am. am. am. app Ha. am. am.
  assert (Hc:domain (graph h) = domain p). uf h. aw.
  set_extens. rwi unionb_rw H8. nin H8. ee. assert (inc x (W x0 h)).
  uf W. am. ufi h H10. rwi Hc H8. awi H10. nin H10. nin H10. wr H11. wr H6.
  app inc_W_target. app (Ha _ H8). am. app Ha. am. am.
  srw. red in H5. ee. wri H6 H8. nin (surjective_pr2 H9 H8). ee. rwi H4 H10.
  red in H1. ee. red in H14. ee. cp H10. wri H16 H10. srwi H10.
  nin H10. ee. exists x1. assert (inc x1 (domain p)). red in H1; ee. wr H12.
  rww H20. split. rww Hc. change (inc x (W x1 h)). uf h. aw. exists x0.
  split;am. app Ha. awi H19. am. am.
Qed.

Lemma number_of_partitions4: forall p E f,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  surjective (BL (fun g => (set_of_partitions_aux p E f g))
    (set_of_permutations E) (set_of_partitions p E)).
Proof. ir. set (phi:=BL (fun g => (set_of_partitions_aux p E f g))
    (set_of_permutations E) (set_of_partitions p E)).
  assert (is_function phi). uf phi. app bl_function. red. ir.
  app number_of_partitions3. app surjective_pr6. uf phi. aw. ir.
  ufi set_of_partitions H3. Ztac.
  assert (Ha:is_finite_set E). red. wr H0. wr inc_Bnat. app finite_sum_finite.
  awi H4. ee. red in H5. ee.
  assert (forall i, inc i (domain p) -> equipotent (W i f) (W i y)).
  ir. cp (H9 _ H11). red in H1; ee. wri (H14 _ H11) H12.
  wr cardinal_equipotent. sy; am. red in H. ee. red in H1; ee.
  set (ha := fun i:Set=> choose (fun z=> bijective z & source z = W i f
    & target z = W i y)).
  assert (forall i, inc i (domain p) ->
    (bijective (ha i) & source (ha i) = W i f & target (ha i) = W i y)).
  ir. uf ha. app choose_pr. app H11.
  assert (domain (graph f) = domain p). red in H1; ee. wr H19; rww H14.
  set (h:= fun i => BL (fun z=> W z (ha i)) (W i f) E).
  assert (forall i, inc i (domain p) -> transf_axioms (fun z => W z (ha i))
    (W i f) E). ir. red. ir. cp (H17 _ H19). ee. wri H22 H20.
  assert (sub (target (ha i)) E). rw H23. ap powerset_sub. wr H7.
  app inc_W_target. rww H8. app H24. app inc_W_target. fct_tac.
  assert(forall i, inc i (domain (graph f)) ->
    function_prop (h i) (V i (graph f)) E).
  rw H18. ir. uf h. red. ee. app bl_function. app H19. aw. aw.
  cp (extension_partition _ H16 H20). nin H21. clear H22. nin H21.
  ee. red in H21; ee. assert(injective x). red. ee. am. ir.
  rwi H23 H25; rwi H23 H26. red in H16. ee. wri H29 H25; wri H29 H26.
  srwi H25. srwi H26. nin H25; nin H26. ee. red in H28. ee.
  nin (H28 _ _ H25 H26). cp (H22 _ H25). red in H33. ee.
  rwi (H35 _ H31) H27. wri H32 H30. rwi (H35 _ H30) H27. ufi h H27.
  awi H27. wri H18 H17. cp (H17 _ H25). ee. red in H36; ee. red in H36; ee.
  app H40. rww H37. rww H37. app H19. wrr H18. am. app H19. wrr H18. am.
  assert (W x0 x = W x0 (h x1)). cp (H22 _ H25). red in H33. ee. app H35.
  assert (W y0 x = W y0 (h x2)). cp (H22 _ H26). red in H34. ee. app H36.
  ufi h H33. awi H33. ufi h H34. awi H34. rwi H18 H25. rwi H18 H26.
  cp (H17 _ H25). ee. assert (inc (W x0 x) (W x1 y)). wr H37. rw H33.
  app inc_W_target. fct_tac. ue.
  cp (H17 _ H26). ee. assert (inc (W y0 x) (W x2 y)). wr H41. rw H34.
  app inc_W_target. fct_tac. ue. red in H10; ee.
  red in H43. red in H5;ee. wri H46 H43. rwi H8 H43.
  nin (H43 _ _ H25 H26). red in H32.
  empty_tac1 y0. rw H47. app intersection2_inc.
  red in H47. empty_tac1 (W x0 x).
  app intersection2_inc. rww H27. app H19. ue.
  am. app H19. ue. am.
  assert (bijective x).
  app bijective_if_same_finite_c_inj. rw H23; rw H24; fprops. ue.
  assert (inc x (set_of_permutations E)). uf set_of_permutations.
  clear H3. Ztac. aw. eee.
  exists x. ee. am. aw.
  assert (y = BL (fun i => image_by_fun x (W i f))
    (domain p) (powerset E)). app function_exten. app bl_function.
  red. ir. app powerset_inc. red. ir. ufi image_by_fun H29. awi H29. nin H29.
  ee. wr H24. nin H25. graph_tac. aw. aw.
  ir. aw. rwi H18 H22. rwi H8 H28.
  cp (H22 _ H28). red in H29. assert (is_function (h x0)).
  wri H18 H28. nin (H20 _ H28); am.
  assert (image_by_fun x (W x0 f) = image_by_fun (h x0) (W x0 f)).
  uf image_by_fun. set_extens. awi H31. nin H31. ee.
  red in H25; ee. cp (W_pr H25 H32). aw. exists x2. ee. am. wr H36.
  red. rw H34. app W_pr3. uf h. aw. am. fprops. fprops.
  awi H31. nin H31. ee. red in H25; ee. cp (W_pr H30 H32). aw. exists x2.
  ee. am. wr H36. red. wr H34. app W_pr3. app H29. am. fprops.
  fprops. rw H31. cp (H17 _ H28). ee. wr H33; wr H34. uf image_by_fun.
  set_extens. aw. red in H32. ee. nin (surjective_pr2 H38 H37). ee.
  exists x2. ee. am. assert (W x2 (ha x0) = W x2 (h x0)). uf h. aw.
  app H19. ue. wr H40. rw H41. app W_pr3. uf h. aw.
  ue. fprops. awi H37. nin H37. ee. rwi H18 H20.
  nin (H20 _ H28). cp (W_pr H39 H38). ufi h H41. rwi bl_W H41.
  wr H41. app inc_W_target. app bij_is_function. app H19. wrr H33.
  app number_of_partitions2. rwi H8 H28. awi H28. am. red in H; ee; am.
  red in H; ee; am. rww H28. red. ir. app number_of_partitions3. red; ee;am.
  red; ee; am.
Qed.

Lemma number_of_partitions5: forall p E f g h,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  inc h (set_of_permutations E) -> inc g (set_of_permutations E) ->
  (set_of_partitions_aux p E f g = set_of_partitions_aux p E f h) =
  (forall i, inc i (domain p) -> image_by_fun (compose (inverse_fun h) g)
     (W i f) = (W i f)).
Proof. ir. cp (number_of_partitions2 (p:=p) f H2).
  cp (number_of_partitions2 (p:=p) f H3).
  ufi set_of_permutations H2. Ztac. clear H2.
  ufi set_of_permutations H3. Ztac. clear H3. awi H6. awi H2. ee.
  uf set_of_partitions_aux.
  assert (Ht:forall i, inc i (domain p) -> sub (W i f) E). nin H1. ir. ee.
  red in H15. ee. wr H17. red. ir. srw. exists i. aw. rw H12. ee. am. am.
  assert (is_function (inverse_fun h)). app bijective_inv_function.
  assert (composable (inverse_fun h) g). red. ee. am. am. aw. ue.
  assert (is_function (compose (inverse_fun h) g)).
  fct_tac. ap iff_eq. ir.
  cp (f_equal (W i) H15). awi H17. set_extens.
  ufi image_by_fun H18. awi H18. nin H18. ee. ufi inverse_fun H19.
  ufi compose H19. awi H19. nin H19. nin H20. nin H20. awi H21.
  assert (inc x1 (image_by_fun h (W i f))). wr H17. uf image_by_fun. aw.
  exists x0. au. ufi image_by_fun H22. awi H22. nin H22. ee.
  nin H7. rww (injective_pr3 H7 H21 H23). uf image_by_fun. aw.
  assert (inc x (source h)). rw H10. ap (Ht _ H16). am.
  assert (inc (W x h) (image_by_fun g (W i f))). rw H17. uf image_by_fun. aw.
  exists x. ee. am. app W_pr3. ufi image_by_fun H20. awi H20.
  nin H20. ee. exists x0. ee. am. uf inverse_fun. uf compose. aw. simpl. aw.
  split. fprops. exists (W x h). ee. am. aw. app W_pr3. am. am. am. am.
  ir. app function_exten. app bl_function. app bl_function. aw. aw. aw.
  ir. rww bl_W. rww bl_W. uf image_by_fun.
  set_extens. awi H17. nin H17. ee. aw. exists (W x0 (inverse_fun h)).
  set (y:= W x0 (inverse_fun h)). assert (y= W x0 (inverse_fun h)). tv.
  assert (inc x0 (target h)). rw H11. wr H9. app (inc_pr2graph_target H2 H18).
  cp (W_inverse H7 H20 H19). assert (inc (J y x0) (graph h)). rw H21.
  app W_pr3. assert (source h = target (inverse_fun h)).
  uf inverse_fun. aw. rw H22. rw H19. app inc_W_target. uf inverse_fun. aw.
  ee. wr (H15 _ H16). aw. exists x1. ee. aw. aw. rww (W_pr H2 H18). graph_tac.
  aw. rw H3. nin H0. ee. nin H1. app Ht. am.
  cp (H15 _ H16). awi H17. nin H17. ee. wri H18 H17. ufi image_by_fun H17.
  ufi compose H17. ufi inverse_fun H17. awi H17. nin H17. ee. awi H20.
  nin H20. nin H21. ee. awi H22. assert (x3 = x0). assert (fgraph (graph h)).
  fprops. rww (fgraph_pr H23 H22 H19). wr H23. aw. ex_tac.
Qed.

Lemma number_of_partitions6: forall p E f h,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  inc h (set_of_permutations E) ->
  transf_axioms (fun g=> L (domain p)(fun i=> (restriction2
    (compose (inverse_fun h) g)
    (W i f) (W i f))))
  (Zo (set_of_permutations E)
    (fun g => (set_of_partitions_aux p E f g = set_of_partitions_aux p E f h)))
  (productb (L (domain p)(fun i=> (set_of_permutations (W i f))))).
Proof. ir. red. ir. aw. ee. gprops. bw. bw. ir. bw. Ztac. clear H3.
  rwi (number_of_partitions5 H H0 H1 H2 H5) H6. cp (H6 _ H4). clear H6.
  ufi set_of_permutations H2. Ztac. clear H2.
  ufi set_of_permutations H5. Ztac. clear H5. awi H6. awi H2. ee.
  assert (is_function (inverse_fun h)). app bijective_inv_function.
  assert (composable (inverse_fun h) c). red. ee. am. am. aw. ue.
  assert (is_function (compose (inverse_fun h) c)). fct_tac.
  set (g:= restriction2 (compose (inverse_fun h) c) (W i f) (W i f)).
  assert (source g = W i f). uf g. uf restriction2. aw.
  assert (target g = W i f). uf g. uf restriction2. aw.
  assert (sub (W i f) E). red in H1. ee. red in H19. ee. wr H21. red. ir.
  srw. exists i. ee. aw. ue. am.
  assert (restriction2_axioms (compose (inverse_fun h) c) (W i f) (W i f)).
  red. aw. ee. am. ue. ue. ue.
  assert (is_function g). uf g. app restriction2_function. bw.
  uf set_of_permutations. Ztac. aw. eee.
  app bijective_if_same_finite_c_inj. rww H15. ue.
  red in H; red in H1; ee. red. rww H15. rww H21. cp (H23 _ H4). fprops.
  red. ee. am. ir. ufi g H22. rwi H15 H20; rwi H15 H21.
  assert (inc x (source c)). rw H5. app H17.
  assert (inc y (source c)). rw H5. app H17.
  rwii restriction2_W H22. rwii restriction2_W H22.
  rwii compose_W H22. rwii compose_W H22.
  cp (inverse_bij_is_bij1 H7). nin H25;nin H25.
  assert (W x c = W y c). app H27. aw. rw H11. wr H9.
  app inc_W_target. aw. rw H11. wr H9. app inc_W_target. nin H8; nin H8.
  app H30. gprops.
Qed.

Lemma number_of_partitions7: forall p E f h,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  partition_with_pi_elements p E f ->
  inc h (set_of_permutations E) ->
  bijective(BL (fun g=> L (domain p)(fun i=> (restriction2
    (compose (inverse_fun h) g)
    (W i f) (W i f))))
  (Zo (set_of_permutations E)
    (fun g => (set_of_partitions_aux p E f g = set_of_partitions_aux p E f h)))
  (productb (L (domain p)(fun i=> (set_of_permutations (W i f)))))).
Proof. ir. set (ww:=BL (fun g=> L (domain p)(fun i=> (restriction2
    (compose (inverse_fun h) g)
    (W i f) (W i f))))
  (Zo (set_of_permutations E)
    (fun g => (set_of_partitions_aux p E f g = set_of_partitions_aux p E f h)))
  (productb (L (domain p)(fun i=> (set_of_permutations (W i f)))))).
  cp (number_of_partitions6 H H0 H1 H2). cp H2.
  cp (number_of_partitions2 (p:=p) f H4). rename H5 into Ha.
  ufi set_of_permutations H4. Ztac. clear H4. awi H5. ee.
  set (hi:= inverse_fun h) in *.
  assert (bijective hi). uf hi. app inverse_bij_is_bij1.
  assert (is_function ww). uf ww. ap bl_function. red. am.
  assert (surjective ww). app surjective_pr6. uf ww. aw.
  ir. awi H10. ee. bwi H11. rwi H11 H12.
  set (ha := fun i=> V i y).
  assert (forall i, inc i (domain p) ->
    (bijective (ha i) & source (ha i) = W i f & target (ha i) = W i f)).
  ir. uf ha. cp (H12 _ H13). bwi H14. ufi set_of_permutations H14. Ztac. ee.
  am. awi H15. ee. ue. aw. awi H15; ee; am. am.
  set (hb:= fun i => BL (fun z=> W z (ha i)) (W i f) E).
  red in H1; ee. assert (domain (graph f) = domain p). red in H1. ee. wrr H18.
  assert (forall i, inc i (domain p) -> sub (W i f) E). ir.
  red in H16. ee. wr H20. red. ir. srw. rw H17. ex_tac.
  assert (forall i, inc i (domain p) -> transf_axioms (fun z => W z (ha i))
    (W i f) E). ir. red. ir. cp (H13 _ H19). ee. app (H18 _ H19). wr H23.
  app inc_W_target. fct_tac. ue.
  assert (forall i, inc i (domain (graph f)) -> is_function (hb i)).
  rw H17. ir. uf hb. app bl_function. app H19.
  assert (forall i, inc i (domain (graph f)) -> target (hb i)= E).
  rw H17. ir. uf hb. aw.
  assert (forall i, inc i (domain (graph f)) -> source (hb i) = V i (graph f)).
  rw H17. ir. uf hb. aw.
  assert(Hw:forall i, inc i (domain (graph f)) -> function_prop (hb i)
    (V i (graph f)) E). red. ir. ee. app H20. app H22. app H21.
  cp (extension_partition _ H16 Hw). nin H23. clear H24. nin H23.
  ee. red in H23; ee. assert(injective x). red. ee. am. ir.
  red in H16. ee. rwi H25 H27; rwi H25 H28; wri H31 H27; wri H31 H28.
  srwi H27. srwi H28. nin H27; nin H28. ee. red in H30. ee.
  nin (H30 _ _ H27 H28). cp (H24 _ H27). red in H35. ee.
  rwi (H37 _ H33) H29. wri H34 H32. rwi (H37 _ H32) H29. ufi hb H29.
  awi H29. wri H17 H13. cp (H13 _ H27). ee. red in H38; ee. red in H38; ee.
  app H42. ue. ue. app H19. ue. am. app H19. ue. am.
  assert (W x0 x = W x0 (hb x1)). cp (H24 _ H27). red in H35. ee. app H37.
  assert (W y0 x = W y0 (hb x2)). cp (H24 _ H28). red in H36. ee. app H38.
  ufi hb H35. awi H35. ufi hb H36. awi H36. rwi H17 H27. rwi H17 H28.
  cp (H13 _ H27). ee. assert (inc (W x0 x) (W x1 f)). rw H35. wr H39.
  app inc_W_target. fct_tac. ue.
  cp (H13 _ H28). ee. assert (inc (W y0 x) (W x2 f)). wr H43. rw H36.
  app inc_W_target. fct_tac. ue.
  red in H34. assert (inc (W x0 x) emptyset). wr H34.
  app intersection2_inc. ue. elim (emptyset_pr H45). app H19. ue.
  am. app H19. ue. am. assert (bijective x).
  app bijective_if_same_finite_c_inj. rw H25; rw H26; fprops. ue.
  red. wr H0. wr inc_Bnat. app finite_sum_finite.
  assert (forall i v, inc i (domain p) -> inc v (W i f) -> W v x = W v (ha i)).
  wr H14. ir. rwi H17 H24. wri H14 H24. cp (H24 _ H29). red in H31. ee.
  rw (H33 _ H30). uf hb. bw. aw. app H19. ue.
  assert (forall i v, inc i (domain p) -> inc v (W i f) -> inc (W v x)(W i f)).
  ir. rw (H29 _ _ H30 H31). cp (H13 _ H30). ee. wr H34. app inc_W_target.
  fct_tac. ue.
  assert (composable h x). red. ee. am. am. ue.
  assert (is_function (compose h x)). fct_tac.
  assert (bijective (compose h x)). app compose_bijective.
  set (t:= compose h x).
  assert (inc t (set_of_permutations E)). uf set_of_permutations. Ztac. aw.
  eee. uf t. aw. uf t. aw.
  assert (Hb: inc t (Zo (set_of_permutations E) (fun g =>
    set_of_partitions_aux p E f g = set_of_partitions_aux p E f h))).
  Ztac. uf set_of_partitions_aux. app function_exten.
  app bl_function. app number_of_partitions2. app bl_function. aw. aw. aw.
  ir. rw bl_W. rw bl_W. uf t. uf image_by_fun. set_extens.
  ufi compose H36. awi H36. nin H36. ee. awi H37. nin H37. nin H38. aw.
  cp (H30 _ _ H35 H36). nin H38. exists x3. ee. wrr (W_pr H23 H38). am.
  awi H36. nin H36. ee. cp (H13 _ H35). ee. red in H38.
  assert (inc x2 (target (ha x0))). rw H40. am. ee.
  nin (surjective_pr2 H42 H41). ee. rwi H39 H43. wri (H29 _ _ H35 H43) H44.
  simpl. aw. exists x3. ee. am. uf compose. aw. split. fprops. exists x2. ee.
  wr H44. app W_pr3.
  rw H25. app (H18 _ H35). am. app number_of_partitions2. am.
  app number_of_partitions2. am. exists t. ee. am.
  rw bl_W; try am. uf t.
  assert (compose hi (compose h x) = x). wr compose_assoc. uf hi.
  rww bij_left_inverse. rw H5; wr H26. rww compose_identity_left.
  red in H23; ee; am. red. ee. fct_tac. am. uf hi. aw. am. rw H35.
  app fgraph_exten. gprops. bw. sy; am. ir. bw. bwi H36.
  cp (H12 _ H36). bwi H37. clear Hb. ufi set_of_permutations H37.
  Ztac. awi H38. ee. assert (restriction2_axioms x (W x0 f) (W x0 f)).
  red. ee. am. rw H25. app H18. rw H26. app H18.
  red. ir. ufi image_by_fun H42. awi H42. nin H42. nin H42.
  wr (W_pr H23 H43). app (H30 _ _ H36 H42).
  app function_exten. app restriction2_function. uf restriction2. aw.
  sy; am. uf restriction2. sy; aw. ir. ufi restriction2 H43. awi H43.
  rww restriction2_W. ap (H29 _ _ H36 H43). am. bwi H36. am. gprops.
  split. clear H10. red. ee. am. uf ww. aw. ir.
  rwii bl_W H12. rwii bl_W H12.
  Ztac. clear H11. Ztac. clear H10.
  rwi (number_of_partitions5 H H0 H1 H2 H13) H14.
  rwi (number_of_partitions5 H H0 H1 H2 H11) H15. fold hi in H14.
  fold hi in H15. set (xi:= compose hi x) in *.
  set (yi:=compose hi y) in *.
  assert (source hi = E). uf hi. aw.
  assert (target hi = E). uf hi. aw.
  ufi set_of_permutations H13; ufi set_of_permutations H11. Ztac.
  clear H11. Ztac. clear H13. awi H17. awi H11. ee.
  assert (is_function xi). uf xi. app compose_function. red. eee. fct_tac.
  assert (is_function yi). uf yi. app compose_function. red. eee. fct_tac.
  assert (xi = yi). app function_exten. uf xi; uf yi. aw. ue.
  uf xi; uf yi. aw. ir. ufi xi H25. awi H25. rwi H21 H25.
  red in H1. ee. red in H28. ee. wri H30 H25. rwi unionb_rw H25. nin H25.
  ee. red in H1; ee. wri H33 H25. rwi H26 H25.
  assert (V x1 (L (domain p) (fun i=> (restriction2 xi (W i f)
    (W i f)))) = V x1 (L (domain p) (fun i => (restriction2 yi
      (W i f) (W i f))))). rw H12. tv. bwi H34.
  cp (H14 _ H25); cp (H15 _ H25). set (ls := W x1 f) in *.
  assert (sub ls E). uf ls; wr H30. red. ir. rw unionb_rw. exists x1.
  ee. wrr H33. rww H26. am.
  assert (restriction2_axioms xi ls ls). red. ee. am. uf xi. aw. ue.
  uf xi. simpl. aw. ue. rw H36. fprops.
  assert (W x0 xi = W x0 (restriction2 xi ls ls)). rww restriction2_W.
  assert (restriction2_axioms yi ls ls). red. ee. am. uf yi. aw. ue.
  uf yi. aw. ue. rw H35. fprops. rw H39. sy. rw H34. rww restriction2_W.
  am. am. ufi xi H25; ufi yi H25.
  assert (Hx:composable hi x). red. ee. fct_tac. am. ue.
  assert (Hy:composable hi y). red. ee. fct_tac. am. ue.
  app function_exten. ue. ue. ir. cp (f_equal (W x0) H25).
  do 2 rwii compose_W H27. ufi hi H27.
  assert (inc (W x0 x) (target h)). rw H7. wr H22. app inc_W_target.
  symmetry in H27. cp (W_inverse H6 H28 H27).
  assert (W x0 y = W (W x0 y) (identity (target y))). rww identity_W.
  app inc_W_target. rw H13. ue. pose (bij_right_inverse H6).
  rwi H20 H30. wri H7 H30. wri e H30. bwi H30. awi H30. ue.
  app composable_f_inv. aw. rw H7. wr H20.
  app inc_W_target. rw H13. ue. rw H13. ue. am.
Qed.

Definition factorialC n := nat_to_B (factorial (cardinal_nat n)).

Theorem number_of_partitions: forall p E,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  let num:= factorialC (cardinal E) in
    let den := cardinal_prod (L (domain p) (fun z => factorialC (V z p)))
      in (num = card_mult (cardinal (set_of_partitions p E)) den &
        is_finite_c num & is_finite_c den & den <> card_zero &
        is_finite_set (set_of_partitions p E)).
Proof. ir. nin (number_of_partitions1 H H0).
  assert (Hb: is_finite_set E). red. wr H0. wr inc_Bnat. app finite_sum_finite.
  assert (Hc:is_finite_c num). uf num. wr inc_Bnat. uf factorialC. fprops.
  assert (Hd:is_finite_c den). uf den. wr inc_Bnat. app finite_product_finite.
  red. ee. gprops. bw. red in H. ee. ir. bw. uf factorialC. fprops.
  bw. red in H; ee; am.
  assert (He:den <> card_zero). uf den. wr zero_cardinal_product. bw. ir. bw.
  uf factorialC. red. ir. wri nat_B_0 H3. cp (nat_B_inj _ _ H3).
  symmetry in H4. elim (factorial_nonzero _ H4). gprops.
  assert (num = card_mult (cardinal (set_of_partitions p E)) den).
  ufi set_of_partitions H1. Ztac.
  set (phi:= BL (fun g => (set_of_partitions_aux p E y g))
    (set_of_permutations E) (set_of_partitions p E)).
  cp (number_of_partitions4 H H0 H3). fold phi in H4.
  assert (forall x, inc x (target phi) ->
    cardinal (inv_image_by_fun phi (singleton x)) = den). ir.
  ufi phi H5. awi H5. assert (inc x (target phi)). uf phi.
  aw. nin (surjective_pr2 H4 H6). ee. ufi phi H7. awi H7.
  cp (number_of_partitions7 H H0 H3 H7).
  assert (forall w, bijective w -> cardinal (source w) = cardinal (target w)).
  ir. aw. red. exists w. ee. am. tv. tv. cp (H10 _ H9). clear H9. simpl in H11.
  assert (den= cardinal (productb (L (domain p)
    (fun i => set_of_permutations (W i y))))).
  uf den. uf cardinal_prod. aw. app equipotent_productb. gprops. gprops. bw.
  bw. ir. bw. red in H3. ee. bw. wr cardinal_equipotent. uf factorialC.
  wr (H13 _ H9). set (q:= W i y).
  assert (inc (cardinal q) Bnat). uf q. rw (H13 _ H9). red in H. ee. app H15.
  cp (nat_to_B_pr H15). set (m:= cardinal_nat (cardinal q)) in *.
  symmetry in H16. rw (number_of_permutations _ H16). fprops.
  assert (Ha:transf_axioms (fun g =>
     (set_of_partitions_aux p E y g))
    (set_of_permutations E) (set_of_partitions p E)).
  red. ir. app number_of_partitions3.
  assert (Zo (set_of_permutations E) (fun g =>
    set_of_partitions_aux p E y g =
    set_of_partitions_aux p E y x0) =
  inv_image_by_fun phi (singleton x)). uf inv_image_by_fun. red in H4; ee.
  set_extens. Ztac. aw. exists x. ee. fprops.
  assert (x = W x1 phi). uf phi. aw. ufi phi H8. awi H8.
  ue. am. am. rw H16. app W_pr3. uf phi. aw.
  awi H13. nin H13. ee. rwi (singleton_eq H13) H14. clear H1.
  assert (inc x1 (set_of_permutations E)).
  cp (inc_pr1graph_source H4 H14). ufi phi H1. awi H1. aw. Ztac.
  ufi phi H8. awi H8. rw H8. cp (W_pr H4 H14). ufi phi H15.
  rwi bl_W H15. am. am. am. am. am. rwi H12 H11.
  rwi bl_source H11. rwi bl_target H11. rw H11. sy;am. red in H4. ee.
  cp (shepherd_principle H4 H5). ufi phi H7.
  rwi bl_source H7. rwi bl_target H7. wr H7.
  red in Hb. wri inc_Bnat Hb.
  cp (nat_to_B_pr Hb). symmetry in H8.
  rww (number_of_permutations _ H8).
  eee.
  red. rwi H2 Hc. assert (is_cardinal (cardinal (set_of_partitions p E))).
  fprops. red in Hd. ee. app (finite_in_product H3 H4 He).
Qed.

Theorem number_of_partitions_bis: forall p E,
  finite_int_fam p -> cardinal_sum p = cardinal E ->
  cardinal (set_of_partitions p E) =
  card_quo (factorialC (cardinal E))
           (cardinal_prod (L (domain p) (fun z => factorialC (V z p)))).
Proof. ir. cp (number_of_partitions H H0). simpl in H1. ee. rw H1.
  red in H5.
  set (x1:= cardinal (set_of_partitions p E)) in *.
  set (x2:= cardinal_prod (L (domain p) (fun z : Set => factorialC (V z p))))
    in *. rw card_mult_commutative. wri inc_Bnat H5. wri inc_Bnat H3.
  assert (0 <> cardinal_nat x2). red. ir. wri cardinal_nat_zero H6.
  elim H4. sy. wr (nat_to_B_pr H3). wr H6. aw. fprops.
  wr (nat_to_B_pr H5). wr (nat_to_B_pr H3). bw. wrr nat_B_quo.
  rww Ndivides_pr4.
Qed.


Fixpoint binom (n p:nat) {struct n} : nat :=
  match n, p with
    | 0, 0 => 1
    | 0, S m => 0
    | S q, 0 => 1
    | S q, S m => (binom q (S m)) + (binom q m)
end.

Lemma binom0: forall n, binom n 0 = 1.
Proof. ir. induction n. tv. tv.
Qed.

Lemma binom1: forall n, binom n 1 = n.
Proof. ir. induction n. tv. simpl. rw binom0. rww plus_comm. rww IHn.
Qed.

Lemma binom2a: forall n, 2*(binom (S n) 2) = n * S n.
Proof. ir. induction n. tv. set (m:= S n).
  assert (2 *(binom (S m) 2) = 2* (binom m 2) + 2* (binom m 1)).
  wrr mult_plus_distr_l. rw H. rw binom1. uf m. rw IHn.
  wrr mult_plus_distr_r. rw mult_comm. rww plus_comm.
Qed.

Lemma binom2: forall n, binom (S n) 2 = Nquo (n * S n) 2.
Proof. ir. app Ndivides_pr2. rww (binom2a n).
Qed.

Lemma binom_alt_pr: forall n m,
  (binom n m)* (factorial m) * (factorial (n-m)) =
  if(le_lt_dec m n) then (factorial n) else 0.
Proof.
  set (binom_alt:= fun n m => (binom n m)* (factorial m) * (factorial (n-m))).
  assert(ba4: forall n m, binom_alt (S n) (S m)=
  (binom_alt n (S m)) *(if le_lt_dec n m then 1 else (n-m))+
  (binom_alt n m) *(S m)).
  ir. set (x:= binom_alt n m). set (y:= binom_alt n (S m)).
  uf binom_alt. simpl. wr mult_assoc. rw mult_plus_distr_r.
  set (A:= binom n (S m) * (factorial m * S m * factorial (n - m))).
  set (B:= binom n m * (factorial m * S m * factorial (n - m))).
  assert (B= x* (S m)). uf x. uf binom_alt. wr mult_assoc.
  rw (mult_comm (factorial (n - m)) (S m)). rw mult_assoc.
  uf B. rw mult_assoc. rw mult_assoc. tv. wr H. clear H.
  set (t:= if le_lt_dec n m then 1 else n - m). uf A. wr factorial_succ.
  rw mult_assoc. uf y. uf binom_alt. set (ff:=binom n (S m) * factorial (S m)).
  assert (factorial (n - m) = factorial (n - S m) *t). uf t.
  case le_lt_dec. ir. rw (minus_wrong l).
  rw (minus_wrong (le_S _ _ l)). tv. ir. rw (pred_minus l). tv.
  rww H. rww mult_assoc.
  intro n. induction n. ir. simpl. case m. tv. simpl. tv.
  ir. induction m. simpl. rww plus_comm. ufi binom_alt ba4. rw ba4.
  rw IHn. rw IHn.
  case le_lt_dec. ir. cp (le_Sn_le _ _ l).
  assert((if le_lt_dec (S m) (S n) then factorial (S n) else 0)=factorial(S n)).
  case le_lt_dec. tv. ir. elim (le_not_lt _ _ H). app lt_S_n. rw H0.
  assert((if le_lt_dec m n then factorial n else 0) = factorial n).
  case le_lt_dec. tv. ir. elim (le_not_lt _ _ H). am. rw H1.
  case le_lt_dec. ir. elim (le_Sn_n m). ap (le_trans _ _ _ l l0). ir.
  wr mult_plus_distr_l. assert (n - m + S m = S n).
  rw plus_comm. rw Sn_is_1plus. wr plus_assoc. wrr le_plus_minus. rww H2.
  ir. rw mult_0_l. rw plus_0_l.
  case le_lt_dec. ir. red in l. cp (le_S_n _ _ l). rw (le_antisym _ _ l0 H).
  case le_lt_dec. tv. ir. elim (lt_irrefl _ l1).
  ir. case le_lt_dec. ir. tv. elim (lt_not_le _ _ l0). app le_S_n. tv.
Qed.

Lemma binom_pr: forall n p, p <=n ->
  Ndivides ((factorial p) * (factorial (n- p))) (factorial n).
Proof. ir. cp (binom_alt_pr n p). destruct (le_lt_dec p n).
  wr H0. wr mult_assoc.
  set (t:=factorial p * factorial (n - p)). rw mult_comm. app Ndivides_pr1.
  uf t. app non_zero_mult. fprops. fprops. elim (le_not_lt _ _ H). am.
Qed.

Lemma binom_pr0: forall n p,
  p>n -> binom n p = 0.
Proof. ir. cp (binom_alt_pr n p). destruct (le_lt_dec p n).
  elim (le_not_lt _ _ l). am. wri mult_assoc H0.
  set (t:=factorial p * factorial (n - p)) in H0.
  assert (0 <> t). uf t. app non_zero_mult. fprops. fprops.
  set (x:= binom n p) in *. induction x. tv.
  assert (0 <> S x). tv. elim (non_zero_mult H2 H1). sy; am.
Qed.

Lemma binom_pr1: forall n p,
  p<=n -> binom n p = Nquo (factorial n) ( (factorial p) * (factorial (n -p))).
Proof. ir. cp (binom_alt_pr n p). destruct (le_lt_dec p n). ir.
  wr H0. wr mult_assoc.
  set (t:=factorial p * factorial (n - p)). rw mult_comm. sy. app Ndivides_pr4.
  uf t. app non_zero_mult. fprops. fprops. elim (le_not_lt _ _ H). am.
Qed.

Lemma binom_pr2: forall n p,
  (binom (n+1) (p+1)) = (binom n (p+1)) + (binom n p).
Proof. ir. wr (Sn_is_plus1). wr (Sn_is_plus1). tv. Qed.

Lemma binom_symmetric:forall n p, p <=n ->
  binom n p = binom n (n -p).
Proof. ir. rww binom_pr1. rww mult_comm. rww binom_pr1.
  rww double_subN. ap le_minus.
Qed.

Lemma lt_plus: forall a b, 0 <>a -> b < b+a.
Proof. ir. nin (nonzero_suc H). rw H0. rw (Sn_is_1plus). rw plus_assoc.
  app lt_plus_trans. rw plus_comm. auto.
Qed.

Lemma binom_pr3: forall n p,
  p<=n -> 0 <> binom n p.
Proof. ir. assert (0 < binom n p).
  ap (le_elim_rel (fun p n => 0 < binom n p)).
  ir. elim p0. au. ir. au. ir. simpl. rw plus_comm. app lt_plus_trans. am.
  app lt_O_neq.
Qed.

Lemma binom_monotone1: forall k n m, 0<k<= S n -> n < m ->
  binom n k < binom m k.
Proof. assert(forall k n, 0<k<= S n -> binom n k < binom (S n) k).
  ir. nin H. nin H. simpl. rw binom0. app lt_plus.
  simpl. app lt_plus. app binom_pr3. autoa.
  ir. induction H1. app H. apply lt_trans with (binom m k). am.
  app H. nin H0. split. am. apply le_trans with (S n). am. autoa.
Qed.

Lemma binom_monotone2: forall k n m, 0<k-> k<= (S n) -> k<= (S m) ->
  (n < m) = (binom n k < binom m k).
Proof. ir. ap iff_eq. app binom_monotone1. au.
  ir. nin (le_or_lt n m). nin (le_lt_or_eq _ _ H3). am.
  rwi H4 H2. elim (lt_irrefl _ H2).
  assert (0<k<=S m). au. cp (binom_monotone1 H4 H3).
  elim (lt_asym _ _ H5). am.
Qed.

Lemma binom_nn : forall n, binom n n = 1.
Proof. ir. rww binom_symmetric. wrr minus_n_n. ap binom0.
Qed.

Lemma binomial1: forall n p, inc n Bnat -> inc p Bnat ->
  cardinal_le p n -> finite_int_fam (variantLc p (card_sub n p)).
Proof. ir. red. ee. fprops. bw. ir. try_lvariant H2. fprops.
  red. split. fprops. red. ir. cp (Bnat_stable_sub H H0).
  bwi H4. nin H4. contradiction. bw. fprops. wr two_points_pr2.
  app doubleton_finite.
Qed.

Lemma binomial2: forall n p, inc n Bnat -> inc p Bnat ->
  cardinal_le p n -> cardinal_sum (variantLc p (card_sub n p)) = n.
Proof. ir. change (card_plus p (card_sub n p) = n). app card_sub_pr.
Qed.

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

Lemma cardinal_complement: forall A E, sub A E ->
  card_plus (cardinal A) (cardinal (complement E A)) = cardinal E.
Proof. ir. cp (disjoint_complement E A). sy. cp (union2_complement H).
  wr H1. app card_plus_pr1. fprops. rw H1. fprops.
Qed.

Lemma cardinal_complement1:forall n p E A, inc n Bnat -> inc p Bnat ->
  cardinal E = n -> cardinal A = p -> sub A E ->
  cardinal (complement E A) = card_sub n p.
Proof. ir. cp (cardinal_complement H3). sy. wr H1. wr H2. wr H4.
  rw card_plus_commutative. app card_sub_pr1.
  set (t:= cardinal (complement E A)) in *. bw.
  assert (is_finite_c (card_plus (cardinal A) t)). rw H4. rw H1. fprops.
  assert (is_cardinal (cardinal A)). fprops.
  assert (is_cardinal t). uf t. fprops. ap (is_finite_in_sum H7 H5). ue.
Qed.

Lemma subsets_with_p_elements_pr: forall n p E, inc n Bnat -> inc p Bnat ->
  cardinal E = n ->
  cardinal (set_of_partitions (variantLc p (card_sub n p)) E) =
  cardinal (subsets_with_p_elements p E).
Proof. ir. aw. assert (transf_axioms (fun z => W TPa z)
  (set_of_partitions (variantLc p (card_sub n p)) E)
  (subsets_with_p_elements p E)). red. ir. ufi set_of_partitions H2. Ztac.
  bwi H3. bwi H4. red in H4. ee. bwi H6.
  uf subsets_with_p_elements. clear H2. Ztac. awi H3. ee. wr H8.
  app inc_W_target. rw H3. fprops. rw (H6 _ inc_TPa_two_points). bw.
  exists (BL (fun z => W TPa z)
  (set_of_partitions (variantLc p (card_sub n p)) E)
  (subsets_with_p_elements p E)). ee; aw. app bl_bijective. ir.
  ufi set_of_partitions H3. ufi set_of_partitions H4.
  Ztac; clear H4. Ztac; clear H3. bwi H6; bwi H4. awi H6; awi H4. ee.
  red in H7. ee. red in H8. ee. bwi H13; bwi H16.
  app function_exten. ue. ue. rw H4. ir. try_lvariant H18.
  assert (W TPb u = complement E (W TPa u)). red in H17. ee. red in H19; ee.
  assert (domain (graph u) = two_points). red in H8; ee. ue.
  rwi H21 H19. nin (H19 _ _ inc_TPa_two_points inc_TPb_two_points).
  elim (two_points_distinct). am. set_extens. rw inc_complement. ee.
  assert (inc (W TPb u) (target u)). app inc_W_target. rw H4. fprops.
  rwi H9 H24. app (powerset_sub H24). red in H22. red. ir.
  assert (inc x0 emptyset). wr H22. app intersection2_inc.
  elim (emptyset_pr H25). rwi inc_complement H23. ee. wri H20 H23.
  srwi H23. nin H23. rwi H21 H23. ee. rwi two_points_pr H23. nin H23.
  elim H24. wrr H23. wrr H23. rw H19; clear H19.
  assert (W TPb v = complement E (W TPa v)). red in H14. ee. red in H19; ee.
  assert (domain (graph v) = two_points). red in H7; ee. wr H22. am.
  rwi H21 H19. nin (H19 _ _ inc_TPa_two_points inc_TPb_two_points).
  elim (two_points_distinct). am. set_extens. srw. ee.
  assert (inc (W TPb v) (target v)). app inc_W_target. rw H10. bw. fprops.
  rwi H11 H24. app (powerset_sub H24). red in H22. red. ir.
  assert (inc x0 emptyset). wr H22. app intersection2_inc.
  elim (emptyset_pr H25). srwi H23. ee. wri H20 H23.
  srwi H23. nin H23. rwi H21 H23. ee. rwi two_points_pr H23. nin H23.
  elim H24. ue. ue. rw H19; rww H5.
  ir. ufi subsets_with_p_elements H3. Ztac. clear H3. cp (powerset_sub H4).
  set (f:=corresp two_points (powerset E) (partition_with_complement E y)).
  assert (source f = two_points). uf f. aw.
  assert (target f = powerset E). uf f. aw.
  assert (is_function f). uf f. app is_function_pr.
  uf partition_with_complement. fprops. uf partition_with_complement.
  red. ir. app powerset_inc. rwi frange_inc_rw H8. nin H8. nin H8. bwi H8.
  rw H9. try_lvariant H8. app sub_complement. fprops.
  uf partition_with_complement. bw. exists f. ee.
  uf set_of_partitions. Ztac. aw. eee. bw. red. eee. bw. ir. bwi H9.
  uf f. uf W. rw corresp_graph. uf partition_with_complement. try_lvariant H9.
  rww (cardinal_complement1 (n:=n) (p:=p)).
  uf f. aw. app is_partition_with_complement.
  uf f. uf W. aw. uf partition_with_complement. bw.
Qed.

Lemma binomial3: forall n p, inc n Bnat -> inc p Bnat ->
  cardinal_le p n -> let pp:=variantLc p (card_sub n p) in
    cardinal_prod (L (domain pp) (fun z => factorialC (V z pp))) =
    card_mult (factorialC p) (factorialC (card_sub n p)).
Proof. ir. uf pp. bw. rw card_mult_pr0. bw.
Qed.

Lemma binomial4: forall n p E, inc n Bnat -> inc p Bnat -> cardinal_le p n ->
  cardinal E = n -> let num:= factorialC n in
    let den := card_mult (factorialC p) (factorialC (card_sub n p))
      in (num = card_mult (cardinal (subsets_with_p_elements p E)) den &
        is_finite_c num & is_finite_c den & den <> card_zero &
        is_finite_set (subsets_with_p_elements p E)).
Proof. ir. set (pp:= variantLc p (card_sub n p)).
  cp (binomial1 H H0 H1). cp (binomial2 H H0 H1). cp (binomial3 H H0 H1).
  cp (subsets_with_p_elements_pr H H0 H2).
  simpl in H5. set (q:= card_sub n p) in *. wri H2 H4.
  cp (number_of_partitions H3 H4). simpl in H7. rwi H2 H7. fold num in H7.
  uf is_finite_set. ufi is_finite_set H7. rwi H6 H7.
  set (ww:= cardinal (subsets_with_p_elements p E)) in *.
  rwi H5 H7. fold den in H7. am.
Qed.

Lemma bijective_complement: forall n p E, inc n Bnat -> inc p Bnat ->
  cardinal_le p n -> cardinal E = n ->
  bijective(BL (fun z => complement E z)
    (subsets_with_p_elements p E)(subsets_with_p_elements (card_sub n p) E)).
Proof. ir. app bl_bijective.
  red. uf subsets_with_p_elements. ir. Ztac. aw. awi H4. app sub_complement.
  app cardinal_complement1. awi H4. am.
  uf subsets_with_p_elements. ir. Ztac. clear H4. Ztac. awi H6. awi H4.
  wr (double_complement H4). rw H5. app double_complement.
  uf subsets_with_p_elements. ir. Ztac. clear H3. awi H4.
  exists (complement E y). rw (double_complement H4). split. Ztac.
  aw. app sub_complement.
  cp (Bnat_stable_sub H H0). rw (cardinal_complement1 H H3 H2 H5 H4).
  app double_sub. red. au. tv.
Qed.

Lemma binomial5: forall n p E, p<= n -> cardinal E = nat_to_B n ->
  let num:= factorial n in
    let den := (factorial p) * (factorial (n - p)) in
      let swp := subsets_with_p_elements (nat_to_B p) E in
        (num = (cardinal_nat swp) * den & 0 <> den & is_finite_set swp).
Proof. ir. pose (inc_nat_to_B n). pose (inc_nat_to_B p).
  assert (cardinal_le (nat_to_B p) (nat_to_B n)). bw.
  wr (cardinal_nat_cardinal swp).
  destruct (binomial4 i i0 H1 H0) as [H2 [_ [ _ [_ H3]]]].
  simpl in H2. fold swp in H2.
  ufi factorialC H2. wri nat_B_sub H2. repeat rwi nat_to_B_pr1 H2.
  wri nat_B_mult H2. fold den in H2. fold swp in H2. split.
  app nat_B_inj. uf num. rw H2. aw. bw. split. uf den.
  app non_zero_mult. fprops. fprops. am.
Qed.

Theorem binomial7: forall n p E, cardinal E = nat_to_B n ->
  cardinal (subsets_with_p_elements (nat_to_B p) E) = nat_to_B(binom n p).
Proof. ir. nin (p_or_not_p (p<=n)). ir.
  cp (binomial5 H0 H). simpl in H1.
  set (swp:= subsets_with_p_elements (nat_to_B p) E) in *.
  assert ( cardinal_nat swp = binom n p).
  rww binom_pr1. set (den:= factorial p * factorial (n - p)) in *. nin H1.
  rw H1. app Ndivides_pr2. intuition. ap mult_comm. wr H2.
  wr (cardinal_nat_cardinal swp). aw. fprops. bw. intuition.
  ir. assert(subsets_with_p_elements (nat_to_B p) E = emptyset).
  ap is_emptyset. ir. red. ir. ufi subsets_with_p_elements H1. Ztac.
  rwi powerset_inc_rw H2. cp (sub_smaller H2).
  rwi H3 H4; rwi H H4. bwi H4. elim H0. am. rw H1. rw cardinal_emptyset.
  rww binom_pr0.
  nin (le_or_lt p n). elim H0. am. am.
Qed.

Lemma sum_of_binomial: forall n, inc n Bnat ->
  cardinal_sum (L (interval_Bnat card_zero n)
    (fun p => nat_to_B(binom (cardinal_nat n) (cardinal_nat p)))) =
  card_pow card_two n.
Proof. ir. wr card_powerset. set (idx:= interval_Bnat card_zero n).
  set (X:= L idx (fun p=>subsets_with_p_elements p n)).
  set (Y:= disjoint_union_fam X). assert (fgraph X). uf X. gprops.
  assert (fgraph Y). uf Y. uf disjoint_union_fam. gprops.
  assert (domain X = domain Y). uf Y. uf disjoint_union_fam. bw.
  assert (forall i, inc i (domain X) -> equipotent (V i X) (V i Y)).
  ir. uf Y. uf disjoint_union_fam. bw. fprops.
  assert (mutually_disjoint X). uf X. red. bw. ir. nin (equal_or_not i j).
  left. am. right. red. app is_emptyset. ir. red. ir. bwi H7.
  ufi subsets_with_p_elements H7. cp (intersection2_first H7).
  cp (intersection2_second H7). Ztac. clear H9. Ztac. elim H6.
  wr H11; wrr H12. am. am. assert (mutually_disjoint Y). uf Y. fprops.
  cp (equipotent_disjoint_union H0 H1 H2 H3 H4 H5).
  assert (unionb X = powerset n). uf X. set_extens. nin (unionb_exists H7).
  bwi H8. ee. ufi subsets_with_p_elements H9. Ztac. am. nin H8. am.
  srw. exists (cardinal x).
  assert (inc (cardinal x) idx). uf idx. rw interval_Bnat_pr0.
  rwi powerset_inc_rw H7. cp (sub_smaller H7).
  assert (cardinal n = n). fprops. rwi H9 H8. am. am.
  split. bw. bw. uf subsets_with_p_elements. Ztac. rwi H7 H6.
  wri cardinal_equipotent H6. rw H6. uf Y.
  set (Z:= L idx (fun p => nat_to_B(binom (cardinal_nat n) (cardinal_nat p)))).
  change (cardinal_sum Z = cardinal_sum X). uf X; uf Z.
  app cardinal_sum_pr3. gprops. bw. bw. ir. bw.
  assert (cardinal n = nat_to_B (cardinal_nat n)). aw. fprops.
  ufi idx H8. wr (nat_to_B_pr (sub_interval_Bnat H8)).
  rw (binomial7 _ (cardinal_nat i) H9). aw. fprops.
Qed.

Lemma sum_of_binomial1: forall n,
  fct_sum (fun p => binom n p) (S n) = pow 2 n.
Proof. ir. cp (l_to_fct2 (fun p => binom n p) n).
  set (g:= fun p : nat => binom n p) in *.
  set (N:= nat_to_B n). cp (inc_nat_to_B n).
  cp (sum_of_binomial H0). ufi g H. rwi nat_to_B_pr1 H1. rwi H H1.
  wri list_sum_pr H1. app nat_B_inj. uf g. uf fct_sum. rw H1. wr nat_B_2. aw.
Qed.

Lemma sum_of_binomial2: forall n,
  fct_sum (binom n) (S n) = pow 2 n.
Proof. ir. induction n. tv. assert (2 ^ S n = 2^n + 2^n). simpl.
  rw mult_comm. simpl. autoa. rw H. clear H. rw fct_sum_rec1.
  assert ((fun i : nat => binom (S n) (S i)) =
    fun i => ((binom n (S i)) + (binom n i))). app arrow_extensionality.
  rw H. wr fct_sum_plus. rw IHn. rw plus_assoc.
  cp (fct_sum_rec1 (binom n) (S n)). assert (binom n 0 = binom (S n) 0).
  rww binom0. wr H1. wr H0. rw fct_sum_rec. rw binom_pr0. rw IHn.
  rw plus_0_r. tv. autoa.
Qed.

Lemma two_plus_two: card_plus card_two card_two = card_four.
Proof. uf card_four. uf card_three. uf succ. wr card_plus_associative.
  rw card_two_pr. tv.
Qed.

Lemma two_times_n: forall n, card_mult card_two n = card_plus n n.
Proof. ir. set (m:= cardinal n). assert (is_cardinal m). uf m. fprops.
  assert (card_plus n n= card_plus m m). uf m. app cardinal_sum_pr2. fprops.
  fprops. rw H0. assert (card_mult card_two n= card_mult card_two m).
  rw card_mult_pr1. rw card_mult_pr1. aw. app equipotent_product. fprops.
  uf m. fprops. rw H1. rw card_two_pr. rw cardinal_distrib_prod_sum2. aw.
Qed.

Lemma two_times_two: card_mult card_two card_two = card_four.
Proof. uf card_four. uf card_three. uf succ. wr card_plus_associative.
  wr card_two_pr. app two_times_n.
Qed.

Lemma power_2_4: card_pow card_two card_four = card_pow card_four card_two.
Proof. ir. set (t:= card_pow card_two card_four). wr two_times_two.
  rw power_of_prod2. uf t. wr two_plus_two. rw power_of_sum2. tv.
Qed.

Lemma strict_increasing_prop : forall p f r, inc p Bnat -> is_function f ->
  source f = interval_co_0a (succ p) -> order r -> substrate r = target f ->
  (forall n, cardinal_lt n p -> glt r (W n f) (W (succ n) f)) ->
  (injective f &
    strict_increasing_fun f (interval_Bnato card_zero p) r).
Proof. ir. assert (inc card_zero Bnat). fprops.
  assert (Ha:interval_Bnat card_zero p = source f). rw H1. app interval_co_cc.
  cp (worder_total (interval_Bnato_worder H5 H)).
  assert (strict_increasing_fun f (interval_Bnato card_zero p) r).
  red. ir. ee. am. nin H6; am. nin Bnat_order_worder; am.
  rww interval_Bnato_substrate. am. ir. nin H7.
  rwii interval_Bnato_related H7. nin H7. nin H9.
  assert (cardinal_lt x y). red; split; am.
  assert (inc x Bnat). app (sub_interval_Bnat H7).
  assert (inc y Bnat). app (sub_interval_Bnat H9).
  wri (lt_n_succ_le H12 H13) H11.
  assert (inc (succ x) Bnat). fprops. nin (card_sub_pr0 H13 H14 H11).
  set (q:=(card_sub0 y (succ x))) in *. wr H16.
  set (pr:= fun q => (cardinal_le (card_plus (succ x) q) p ->
    glt r (W x f) (W (card_plus (succ x) q) f))).
  assert (forall q, inc q Bnat -> pr q). app cardinal_c_induction_v.
  uf pr. rw zero_unit_sumr. ir. app H4. assert (is_cardinal x). fprops.
  wrr lt_n_succ_le. fprops.
  uf pr. ir. set (m:= card_plus (succ x) n) in *.
  assert (succ m = card_plus (succ x) (succ n)). uf m. set (sx:= succ x).
  uf succ. rww card_plus_associative. wr H20. wri H20 H19.
  assert (cardinal_le m p). assert (is_cardinal m). uf m. fprops.
  cp (is_less_than_succ H21). app (cardinal_le_transitive H22 H19).
  assert (cardinal_lt m p). wrr lt_n_succ_le. uf m. fprops.
  cp (H18 H21). cp (H4 _ H22). nin H23. order_tac.
  ap (H17 _ H15). rw H16. rwi interval_Bnat_pr0 H9. am. am.
  cp (total_order_increasing_morphism H6 H7). nin H8. ee. am. am.
Qed.

Lemma strict_increasing_prop1: forall f p,
  inc p Bnat -> (forall i, cardinal_lt i p -> inc (f i) Bnat)
  -> (forall i j, cardinal_lt i j -> cardinal_lt j p ->
    cardinal_lt (f i) (f j)) ->
  (forall i, cardinal_lt i p -> cardinal_le i (f i)).
Proof. ir.
  set (pr:= fun i=> cardinal_lt i p -> cardinal_le i (f i)).
  app (cardinal_c_induction_v pr). uf pr. ir.
  app zero_smallest. cp (H0 _ H3). fprops. uf pr. ir.
  assert (is_cardinal n). fprops. cp (is_less_than_succ H6).
  assert (cardinal_lt n p). co_tac. cp (H4 H8). srw.
  assert (cardinal_lt n (succ n)). srw. fprops. fprops.
  cp (H1 _ _ H10 H5). co_tac. fprops. nin H2. Bnat_tac.
Qed.

Lemma increasing_prop1 : forall p f r, inc p Bnat -> order r ->
  (forall i, cardinal_le i p -> inc (f i) (substrate r)) ->
  (forall n, cardinal_lt n p -> gle r (f n) (f (succ n))) ->
  (forall i j, cardinal_le i j -> cardinal_le j p ->
    gle r (f i) (f j)).
Proof. ir. assert (inc card_zero Bnat). fprops.
  nin (equal_or_not i j). rw H6. order_tac. app H1.
  assert (cardinal_lt i j). red; split; am.
  assert (inc j Bnat). Bnat_tac.
  assert (inc i Bnat). Bnat_tac.
  assert (inc (succ i) Bnat). fprops. wri (lt_n_succ_le H9 H8) H7.
  nin (card_sub_pr0 H8 H10 H7).
  set (q:=(card_sub0 j (succ i))) in *. wr H12.
  set (pr:= fun q => (cardinal_le (card_plus (succ i) q) p ->
    gle r (f i) (f (card_plus (succ i) q)))).
  assert (forall q, inc q Bnat -> pr q). app cardinal_c_induction_v.
  uf pr. rw zero_unit_sumr. ir. app H2. assert (is_cardinal i). fprops.
  wrr lt_n_succ_le. fprops.
  uf pr. ir. set (m:= card_plus (succ i) n) in *.
  assert (succ m = card_plus (succ i) (succ n)). uf m. set (sx:= succ i).
  uf succ. rww card_plus_associative. wr H16. wri H16 H15.
  assert (cardinal_le m p). assert (is_cardinal m). uf m. fprops.
  cp (is_less_than_succ H17). co_tac.
  assert (cardinal_lt m p). wrr lt_n_succ_le. uf m. fprops.
  cp (H14 H17). cp (H2 _ H18).
  cp (order_transitivity H0 H19 H20). am. app H13. ue.
Qed.

Lemma increasing_prop : forall p f r, inc p Bnat -> is_function f ->
  source f = interval_co_0a (succ p) -> order r -> substrate r = target f ->
  (forall n, cardinal_lt n p -> gle r (W n f) (W (succ n) f)) ->
  increasing_fun f (interval_Bnato card_zero p) r.
Proof. ir. red.
  assert (inc card_zero Bnat). fprops.
  assert (Ha:interval_Bnat card_zero p = source f). rw H1. app interval_co_cc.
  cp (worder_total (interval_Bnato_worder H5 H)). ee. am. nin H6; am. am.
  rww interval_Bnato_substrate. am. ir.
  rwi interval_Bnato_related H7. ee.
  assert (forall i, cardinal_le i p -> inc (W i f) (substrate r)). rw H3.
  ir. app inc_W_target. rw H1. rww interval_co_0a_pr3.
  assert (forall n, cardinal_lt n p -> gle r (W n f) (W (succ n) f)).
  ir. app H4. app (increasing_prop1 _ H H2 H10 H11).
  rwi interval_Bnat_pr0 H8. am. am. fprops. am.
Qed.

Lemma strict_increasing_prop2: forall f p,
  inc p Bnat -> (forall i, cardinal_lt i p -> inc (f i) Bnat)
  -> (forall i j, cardinal_lt i j -> cardinal_lt j p ->
    cardinal_lt (f i) (f j)) ->
  (forall i j, cardinal_le i j -> cardinal_lt j p ->
    cardinal_le (card_sub (f i) i) (card_sub (f j) j)).
Proof. ir. assert (inc j Bnat). nin H3. ap (le_int_in_Bnat H3 H).
  nin (equal_or_not p card_zero). rwi H5 H3. elim (zero_smallest1 H3).
  assert (is_finite_c p). wrr inc_Bnat. cp (predc_pr H6 H5). nin H7.
  set (q:= predc p).
  assert (inc q Bnat). bw.
  set(r:=Bnat_order).
  assert (forall i, cardinal_le i q -> inc (card_sub (f i) i)(substrate r)).
  uf r. rw Bnat_order_substrate. ir. app Bnat_stable_sub. app H0.
  rw H8. srw. Bnat_tac.
  nin (Bnat_order_worder). clear H12.
  assert (forall n, cardinal_lt n q -> gle r (card_sub (f n) n)
    (card_sub(f (succ n)) (succ n))). ir.
  cp (strict_increasing_prop1 _ H H0 H1).
  assert (inc n Bnat). nin H12. Bnat_tac.
  assert (cardinal_lt (succ n) p). rw H8. srw. fprops.
  assert (cardinal_lt n (succ n)). srw. fprops. fprops.
  assert (cardinal_lt n p). nin H16. co_tac.
  cp (H13 _ H17). cp (H13 _ H15).
  uf r. rw Bnat_order_le. red. ee. fprops. fprops. cp (H1 _ _ H16 H15).
  assert (inc (f n) Bnat). app H0. cp (card_sub_pr H21 H14 H18).
  set (a:= card_sub (f n) n) in *. wri H22 H20.
  assert (inc (f (succ n)) Bnat). app H0. assert (inc (succ n) Bnat). fprops.
  cp (card_sub_pr H23 H24 H19). set (b:= card_sub (f (succ n)) (succ n)) in *.
  wri H25 H20. ufi succ H20. wri card_plus_associative H20.
  assert (inc a Bnat). uf a. fprops. assert (inc b Bnat). uf b. fprops.
  assert (inc (card_plus card_one b) Bnat). fprops.
  cp (Bnat_plus_lt_simplifiable H14 H26 H28 H20).
  srw. wrr lt_is_le_succ. uf succ. rw card_plus_commutative. am. wrr inc_Bnat.
  rwi H8 H3. srwi H3.
  cp (increasing_prop1 _ H9 H11 H10 H12 H2 H3). simpl in H13.
  rwi Bnat_order_le H13. nin H13. ee; am. fprops.
Qed.

Lemma strict_increasing_prop3: forall f p n,
  inc p Bnat -> inc n Bnat -> (forall i, cardinal_lt i p -> inc (f i) Bnat)
  -> (forall i j, cardinal_lt i j -> cardinal_lt j p ->
    cardinal_lt (f i) (f j)) ->
  (forall i, cardinal_lt i p -> cardinal_lt (f i) (card_plus n p)) ->
  (forall i, cardinal_lt i p -> cardinal_le (card_sub (f i) i) n).
Proof. ir. nin (equal_or_not p card_zero). rwi H5 H4. elim (zero_smallest1 H4).
  assert (is_finite_c p). fprops. cp (predc_pr H6 H5). nin H7.
  rwi H8 H4. srwi H4. assert (cardinal_lt (predc p) p). rw H8. srw. ue.
  apply cardinal_le_transitive with (card_sub (f (predc p)) (predc p)).
  ap (strict_increasing_prop2 _ H H1 H2 H4 H9).
  cp (strict_increasing_prop1 _ H H1 H2 H9).
  assert (inc (f (predc p)) Bnat). app H1. assert (inc (predc p) Bnat).
  bw. cp (card_sub_pr H11 H12 H10).
  set (r:= (card_sub (f (predc p)) (predc p))) in *. cp (H3 _ H9). wri H13 H14.
  assert (card_plus n p = succ (card_plus (predc p) n)). rw H8.
  rw card_plus_commutative. uf succ. wr card_plus_associative. ufi succ H8.
  wrr H8. wr card_plus_associative. rww (card_plus_commutative card_one n).
  rwi H15 H14. apply Bnat_plus_le_simplifiable with (predc p). am.
  uf r. fprops. am. wrr lt_is_le_succ. fprops. fprops.
Qed.

Lemma cardinal_set_of_increasing_functions1: forall r r' f,
  total_order r -> strict_increasing_fun f r r' ->
  (order_morphism f r r' & cardinal (substrate r) = cardinal (image_of_fun f)).
Proof. ir. cp (total_order_increasing_morphism H H0). ee. am. red in H1. ee.
  cp (restriction_to_image_bijective H3).
  aw. exists (restriction_to_image f). split. am.
  uf restriction_to_image. uf restriction2. aw. ee. sy; am. tv.
Qed.

Lemma cardinal_set_of_increasing_functions2: forall r r',
  total_order r -> total_order r' ->
  is_finite_set (substrate r) -> is_finite_set (substrate r') ->
  bijective(BL (fun z => range (graph z))
    (Zo (set_of_functions (substrate r) (substrate r'))
      (fun z=> strict_increasing_fun z r r'))
    (subsets_with_p_elements (cardinal (substrate r)) (substrate r'))).
Proof. ir. rename H1 into Ha; rename H2 into Hb.
  set (src:= Zo (set_of_functions (substrate r) (substrate r'))
  (fun z => strict_increasing_fun z r r')).
  set (trg:= subsets_with_p_elements (cardinal (substrate r)) (substrate r')).
  set (f:= BL(fun z=> range (graph z)) src trg).
  assert(transf_axioms (fun z=> range (graph z)) src trg).
  red. ir. ufi src H1. Ztac. clear H1. awi H2. ee.
  nin (cardinal_set_of_increasing_functions1 H H3).
  assert (image_of_fun c = range (graph c)). uf image_of_fun.
  red in H1. ee. rw H8. rw image_by_graph_domain. tv. fprops.
  uf trg. uf subsets_with_p_elements. Ztac. ap powerset_inc. wr H4.
  nin H1. fprops. wr H7. sy. am.
  uf f. app bl_bijective. uf src. ir.
  Ztac. clear H3. Ztac. clear H2. awi H5; awi H3. ee.
  set (ci:= canonical_injection (range (graph u)) (target u)).
  assert (ci= canonical_injection (range (graph u)) (target u)). tv.
  assert (ci= canonical_injection (range (graph v)) (target v)).
  wr H4. rw H10; wr H8. am.
  set (g0:= restriction2 u (source u) (range (graph u))).
  set (g1:= restriction2 v (source v) (range (graph v))).
  assert (g0= restriction2 u (source u) (range (graph u))). tv.
  assert (g1= restriction2 v (source v) (range (graph v))). tv.
  cp (canonical_decomposition1 H2 H13 H11).
  cp (canonical_decomposition1 H5 H14 H12). ee.
  set (tg:= range(graph u)). cp (total_order_increasing_morphism H H7).
  cp (total_order_increasing_morphism H H6). red in H25. red in H26. ee.
  set (T:= range (graph u)). set (r'' := induced_order r' T).
  assert (sub T (substrate r')). rw H35. uf T. nin H2; fprops.
  cp (total_order_sub H0 H37). fold r'' in H37.
  assert (substrate r'' = T). uf r''. aw.
  assert (equipotent (substrate r) (substrate r'')). rw H39. uf T.
  rw H34. exists g0. ee. app H24. uf g0. uf restriction2. aw.
  uf g0. uf restriction2. aw. nin (isomorphism_worder_finite H H38 Ha H40).
  assert (g0 = g1). app H42. red. ee. am. nin H38; am. app H24.
  uf g0. uf restriction2. aw. uf g0. uf restriction2. aw.
  assert (Hc:restriction2_axioms u (source u) (range (graph u))).
  red. ir. ee. am. fprops. nin H2; fprops.
  uf image_by_fun. app sub_image_by_graph. uf g0. ir.
  ufi restriction2 H43. ufi restriction2 H44. awi H43. awi H44.
  rww restriction2_W. rww restriction2_W.
  rww H36. aw. uf T. app inc_W_range_graph. uf T. app inc_W_range_graph.
  red. ee. am. fprops. app H20. uf g1. uf restriction2. aw. uf g1.
  uf restriction2. aw. uf g1.
  assert (Hc:restriction2_axioms v (source v) (range (graph v))).
  red. ir. ee. am. fprops. nin H5. fprops.
  uf image_by_fun. app sub_image_by_graph. ir.
  ufi restriction2 H43. ufi restriction2 H44. awi H43. awi H44.
  rww restriction2_W. rww restriction2_W. rww H31. aw. uf T. rw H4.
  app inc_W_range_graph. uf T. rw H4. app inc_W_range_graph.
  rw H21; rw H17. rw H43. tv.
  uf trg; uf src. ir. ufi subsets_with_p_elements H2. Ztac.
  rwi powerset_inc_rw H3. clear H2.
  set (r'' := induced_order r' y). cp (total_order_sub H0 H3). fold r'' in H2.
  assert (substrate r'' = y). uf r''. aw. red in H0; ee. am.
  assert (equipotent (substrate r) (substrate r'')). rw H5.
  wr cardinal_equipotent. auto.
  cp (isomorphism_worder_finite H H2 Ha H6). nin H7. clear H8. nin H7.
  assert (composable (canonical_injection y (substrate r')) x). red in H7.
  ee. red. ee. app ci_function. app bij_is_function. uf canonical_injection. aw.
  ue. set (g:= compose (canonical_injection y (substrate r')) x).
  assert (is_function g). uf g. fct_tac.
  assert (source g = substrate r). uf g. aw. red in H7. ee. sy; am.
  assert (target g = substrate r'). uf g. uf canonical_injection. aw.
  assert (inc g (Zo (set_of_functions (substrate r) (substrate r'))
    (fun z=> strict_increasing_fun z r r'))). Ztac. aw. eee.
  red. ee. am. nin H; am. nin H0; am. sy; am. sy; am. ir. red in H7. ee.
  assert (inc x0 (source x)). wr H15. order_tac.
  assert (inc y0 (source x)). wr H15. order_tac.
  assert (inc (W x0 x) y). wr H5. rw H16. app inc_W_target. fct_tac.
  assert (inc (W y0 x) y). wr H5. rw H16. app inc_W_target. fct_tac.
  uf g. rww compose_W. rww compose_W. rww ci_W. rww ci_W.
  split. nin H12. rwi (H17 _ _ H18 H19) H12. ufi r'' H12.
  ap (related_induced_order1 H12).
  nin H12. nin H14. nin H14. dneg. app H24.
  exists g. ee. am. uf g. uf compose. uf canonical_injection. aw.
  assert (is_graph (compose_graph (diagonal y) (graph x))). fprops.
  set_extens. awi H14. nin H14. awi H14. ee. nin H15. ee. awi H16. ee. ue.
  fprops. aw. red in H7. ee. nin H17. cp H14. wri H5 H14. rwi H18 H14.
  nin H16. nin (surjective_pr H20 H14). nin H21. exists x1. aw.
  ee. fprops. exists x0. eee. aw. eee. fprops.
Qed.

Lemma cardinal_set_of_increasing_functions: forall r r' n p,
  total_order r -> total_order r' ->
  cardinal (substrate r) = nat_to_B p ->
  cardinal (substrate r') = nat_to_B n ->
  cardinal (Zo (set_of_functions (substrate r) (substrate r'))
    (fun z => strict_increasing_fun z r r')) =
  nat_to_B(binom n p).
Proof. ir. assert (is_finite_set (substrate r)). red. rw H1. fprops.
  assert (is_finite_set (substrate r')). red. rw H2. fprops.
  cp (cardinal_set_of_increasing_functions2 H H0 H3 H4).
  set (src:= Zo (set_of_functions (substrate r) (substrate r'))
    (fun z => strict_increasing_fun z r r')) in *.
  set (trg:= subsets_with_p_elements (cardinal (substrate r)) (substrate r'))
    in *. assert (equipotent src trg).
  exists (BL (fun z => range (graph z)) src trg).
  simpl. ee. am. aw. aw.
  wr (binomial7 n p H2). wr H1. fold trg. aw.
Qed.

Lemma cardinal_set_of_increasing_functions3: forall n p,
  let r:= interval_Bnatco (nat_to_B p) in
    let r':= interval_Bnato card_zero (nat_to_B n) in
      cardinal (Zo (set_of_functions (substrate r) (substrate r'))
        (fun z => increasing_fun z r r')) =
      nat_to_B(binom (n+p) p).
Proof. ir. set (nn:= nat_to_B n) in *. assert(Hn: inc nn Bnat). uf nn; fprops.
  set (pp:= nat_to_B p) in *. assert(Hp: inc pp Bnat). uf pp; fprops.
  set (np:=(nat_to_B (n+p))). assert(Hnp: inc np Bnat). uf np; fprops.
  set (E1:=interval_co_0a pp). assert (E1= substrate r). uf E1. uf r.
  rww interval_Bnatco_substrate. uf pp. fprops.
  set (E2:=interval_Bnat card_zero nn). assert (E2= substrate r'). uf E2. uf r'.
  rww interval_Bnato_substrate. fprops. uf nn. fprops. wr H. wr H0.
  set (r'':= interval_Bnatco np).
  set (E3:=interval_co_0a np). assert (E3= substrate r''). uf E3. uf r''.
  rww interval_Bnatco_substrate.
  set (Q1:= Zo (set_of_functions E1 E2)
        (fun z : Set => increasing_fun z r r')).
  set (Q2:= Zo (set_of_functions E1 E3)
        (fun z : Set => strict_increasing_fun z r r'')).
  set (P1:= fun x => is_function x & source x = E1 & target x = E2 &
    increasing_fun x r r').
  set (P2:= fun x => is_function x & source x = E1 & target x = E3 &
    strict_increasing_fun x r r'').
  assert (HQ1: forall x, inc x Q1 = P1 x).
  uf Q1. uf P1. ir. app iff_eq; ir; Ztac. awi H3. eee. aw. eee. eee.
  assert (HQ2: forall x, inc x Q2 = P2 x).
  uf Q2. uf P2. ir. app iff_eq; ir; Ztac. awi H3. eee. aw. eee. eee.
  assert (Ha:sub E1 Bnat). uf E1. app sub_interval_co_0a_Bnat.
  assert (Hb:sub E2 Bnat). uf E2. app sub_interval_Bnat.
  assert (Hc:sub E3 Bnat). uf E3. app sub_interval_co_0a_Bnat.
  set (subi:= fun f => BL (fun i=> card_sub (W i f) i) E1 E2).
  assert (Hi0:forall f, inc f Q2 -> (
    (forall i, cardinal_lt i pp -> inc (W i f) Bnat) &
    (forall i j, cardinal_lt i j -> cardinal_lt j pp ->
      cardinal_lt (W i f) (W j f)) &
    (forall i, inc i E1 -> (cardinal_le i (W i f))))).
  ir. rwi HQ2 H2. ufi P2 H2.
  assert (forall i, cardinal_lt i pp -> inc (W i f) Bnat). ee. ir. app Hc.
  wr H4. app inc_W_target. rw H3. uf E1. srw.
  assert(forall i j, cardinal_lt i j -> cardinal_lt j pp ->
    cardinal_lt (W i f) (W j f)). ir. ee. red in H8. ee.
  assert (inc i (source f)). rw H6. uf E1. srw. nin H5. co_tac.
  assert (inc j (source f)). rw H6. uf E1. srw.
  assert (glt r i j). uf r. red. split. rw interval_Bnatco_related. split.
  nin H4. am. am. am. nin H4. am. cp (H13 _ _ H16). ufi r'' H17.
  nin H17. rwi interval_Bnatco_related H17. red. ee. am. am. am. ee. am. am.
  ir. ufi E1 H8. srwi H8.
  ap (strict_increasing_prop1 _ Hp H3 H4 H8). am.
  assert (Hi3:forall f, inc f Q2 ->
    transf_axioms (fun i => card_sub (W i f) i) E1 E2). ir.
  cp (Hi0 _ H2). ee. cp (strict_increasing_prop2 _ Hp H3 H4). simpl in H6.
  red. ir. uf E2. rw interval_Bnat_pr0. ufi E1 H7. srwi H7.
  assert (forall i, cardinal_lt i pp -> cardinal_lt (W i f) (card_plus nn pp)).
  ir. assert (inc (W i f) E3). rwi HQ2 H2. ufi P2 H2. ee. wr H10.
  app inc_W_target. rw H9. uf E1. srw. ufi E3 H9.
  srwi H9. ufi np H9. uf nn; uf pp. bw. am.
  ap (strict_increasing_prop3 _ Hp Hn H3 H4 H8 H7). am. am.
  assert (Hi1:forall f, inc f Q2 ->
    inc (subi f) (set_of_functions E1 E2)).
  ir. cp H2. ufi Q2 H2. Ztac. awi H4. ee. uf subi. aw. eee. app bl_function.
  ap Hi3. am.
  assert (Hi2:forall f, inc f Q2 -> inc (subi f) Q1).
  ir. uf Q1. Ztac. aw. cp H2. cp (Hi1 _ H2). awi H4. ee.
  ufi Q2 H3. Ztac. red in H8. ee. red. ee. am.
  uf r. nin (interval_Bnatco_worder Hp). am. uf r'.
  nin (interval_Bnato_worder inc0_Bnat Hn). am. ue. ue.
  red. ir. assert (inc x (source f)). wr H11. order_tac.
  assert (inc y (source f)). wr H11. order_tac.
  ufi r H14. rwi interval_Bnatco_related H14. ee. uf r'.
  rw interval_Bnato_related. fold E2. wr H6. ee. app inc_W_target. ue.
  rww H. ue. app inc_W_target. rw H5. rww H. ue.
  cp (Hi0 _ H3). ee. cp (strict_increasing_prop2 _ Hp H18 H19). uf subi.
  rw bl_W. rw bl_W. app H21. app Hi3. ue. ue. app Hi3.
  ue. ue. fprops. am. am.
  set (G:= BL (fun f=> subi f) Q2 Q1).
  assert(Hi4:is_function G). red. uf G. app bl_function.

  set (addi:= fun f => BL (fun i=> card_plus (W i f) i) E1 E3).
  assert (forall f, inc f (set_of_functions E1 E2) ->
    transf_axioms (fun i => card_plus (W i f) i) E1 E3).
  red. ir. awi H2. ee. uf E3. srw. uf np. assert (inc (W c f) E2).
  wr H5. app inc_W_target. rww H4. assert (inc (W c f) Bnat). app Hb.
  ufi E2 H6. rwi interval_Bnat_pr0 H6. ufi nn H6.
  cp (nat_to_B_pr H7). set (t:=cardinal_nat (W c f)) in H8. wri H8 H6. bwi H6.
  wr H8. assert (inc c Bnat). app Ha. wr (nat_to_B_pr H9). bw.
  assert (cardinal_nat c < p). ufi E1 H3. srwi H3.
  ufi pp H3. wri (nat_to_B_pr H9) H3. bwi H3. am. am.
  app (plus_le_lt_compat _ _ _ _ H6 H10). am.

  assert (forall f, inc f (set_of_functions E1 E2) ->
    inc (addi f) (set_of_functions E1 E3)).
  ir. cp (H2 _ H3). awi H3. ee. uf addi. aw. eee. app bl_function.
  assert (forall f, inc f Q1 -> inc (addi f) Q2).
  ir. ufi Q1 H4. Ztac. clear H4. rw HQ2. cp (H2 _ H5). cp (H3 _ H5). awi H7.
  uf P2. ee. am. am. am. red. ee. am. red in H6; ee; am.
  uf r''. nin (interval_Bnatco_worder Hnp). am. rw H8; sy;am. rw H9; sy; am.
  ir. uf addi. assert (inc x E1). rw H. order_tac. rww bl_W.
  assert (inc y E1). rw H. order_tac. rww bl_W.
  assert (He:inc x Bnat). app Ha. assert (Hex:inc y Bnat). app Ha.
  nin H10. red in H6. ee. cp (H18 _ _ H10).
  ufi r H10. rwi interval_Bnatco_related H10.
  ufi r' H19. rwi interval_Bnato_related H19. ee.
  cp (sub_interval_Bnat H19). cp (sub_interval_Bnat H20).
  assert (cardinal_lt (card_plus (W x f) x)(card_plus (W y f) y)).
  assert (cardinal_lt x y). split; am. app finite_sum2_lt. nin H25.
  uf r''. ee. red. rww interval_Bnatco_related. ee. am.
  rwi interval_Bnat_pr0 H20.
  assert (np = card_plus nn pp). uf np. uf nn. uf pp. aw. rw H27.
  app finite_sum2_lt. am. am. fprops. am. am.
  set (F:= BL (fun f=> (addi f)) Q1 Q2).
  assert(is_function F). red. uf F. app bl_function.
  assert (composable G F). uf G; uf F. red. ee. am. am. aw.
  assert (composable F G). uf G; uf F. red. ee. am. am. aw.
  assert (compose G F = identity (source F)). app function_exten.
  fct_tac. app identity_function. aw. ir. aw.
  uf F. uf G. aw. ir. awi H8.
  rww identity_W. ufi F H8. awi H8. uf F. uf G. aw. cp (H4 _ H8). cp H9.
  ufi Q2 H9. Ztac. clear H9. ufi Q1 H8. Ztac. clear H8. awi H11; awi H9. ee.
  uf subi. app function_exten. app bl_function. app Hi3. aw. sy; am.
  aw. sy; am. aw. ir. rw bl_W. uf addi. rww bl_W.
  app card_sub_pr1. app Hb. wr H14. app inc_W_target. rww H9. app Ha.
  app H2. aw. eee. app Hi3. am. rw bl_W. app H4. am. am.
  assert (compose F G = identity (source G)).
  app function_exten.
  fct_tac. app identity_function. aw. ir. aw. nin H6.
  sy; ee; am. ir. awi H9. rww identity_W. aw. ufi G H9. awi H9.
  uf F. uf G. rww bl_W. rww bl_W. cp (Hi2 _ H9).
  cp H9; cp H10. ufi Q2 H9. Ztac. clear H9. ufi Q1 H10. Ztac. awi H13. awi H9.
  ee. uf addi. app function_exten. app bl_function. app H2. aw; eee.
  aw. sy; am. aw. sy; am. aw. ir. rw bl_W. uf subi.
  rww bl_W. rw card_plus_commutative. app card_sub_pr.
  app Hc. wr H19. app inc_W_target. rww H18. app Ha. cp (Hi0 _ H11).
  ee. app H23. app Hi3. wr H16. aw. rw H16. app H2. aw; eee. am.
  rw bl_W. app Hi2. am. am.
  cp (bijective_from_compose H6 H7 H8 H9).
  assert (equipotent Q1 Q2). exists F. ee. am. uf F; aw. uf F. aw.
  assert (cardinal Q2 = nat_to_B (binom (n + p) p)).
  assert (total_order r). app worder_total. uf r. app interval_Bnatco_worder.
  uf pp. fprops. assert (total_order r''). app worder_total. uf r''.
  app interval_Bnatco_worder. uf np. fprops.
  assert (cardinal (substrate r) = nat_to_B p). uf r.
  rw interval_Bnatco_substrate. rww cardinal_interval_co_0a1. uf pp. fprops.
  uf pp. fprops.
  assert (cardinal (substrate r'') = nat_to_B (n+p)). uf r''.
  rw interval_Bnatco_substrate. rww cardinal_interval_co_0a1. uf np. fprops.
  uf np. fprops. cp (cardinal_set_of_increasing_functions _ _ H12 H13 H14 H15).
  wr H16. wr H. wr H1. tv. wr H12. ir. aw.
Qed.

Lemma increasing_compose: forall f g r r' r'',
  increasing_fun f r r' -> increasing_fun g r' r'' ->
  (composable g f &
    (forall x, inc x (source f) -> W x (compose g f) = W (W x f) g) &
    increasing_fun (compose g f) r r'').
Proof. ir. red in H;red in H0. assert (composable g f). red. eee. split. am.
  assert (forall x, inc x (source f) -> W x (compose g f) = W (W x f) g).
  ir. rww compose_W. split. am. red. ee. fct_tac. am. am. aw. aw.
  red. ir. rww H2. rww H2. cp (H12 _ _ H13). app H7.
  wr H10; order_tac. wr H10; order_tac.
Qed.

Lemma increasing_compose3: forall f g h r r' r'' r''',
  strict_increasing_fun f r r' -> increasing_fun g r' r'' ->
  strict_increasing_fun h r'' r''' ->
  let res:= compose (compose h g) f in
    (inc res (set_of_functions (source f) (target h)) &
      (forall x, inc x (source f) -> W x res = W (W (W x f) g) h) &
      increasing_fun res r r''').
Proof. ir. cp (increasing_fun_from_strict H).
  cp (increasing_fun_from_strict H1). cp (increasing_compose H0 H3).
  nin H4. nin H5. cp (increasing_compose H2 H6). ee.
  assert (source res = source f). uf res. aw.
  assert (target res = target h). uf res. aw.
  uf res. aw. eee. fct_tac.
  ir. rw H8. rw H5. tv. red in H7. ee. awi H12. ue. am. am.
Qed.

Lemma cardinal_set_of_increasing_functions4: forall n p r r',
  total_order r -> total_order r'-> cardinal (substrate r) = nat_to_B p ->
  cardinal (substrate r') = nat_to_B n ->
  cardinal (Zo (set_of_functions (substrate r) (substrate r'))
    (fun z => increasing_fun z r r')) =
  nat_to_B(binom (n+p-1) p).
Proof. ir. nin (p_or_not_p (n=0)). ir.
  set (q':= substrate r). set (q:= substrate r').
  assert (q= emptyset). app cardinal_nonemptyset. uf q. rw H2. rw H3. fprops.
  rw H4. nin (p_or_not_p (p=0)). ir.
  assert (q'= emptyset). app cardinal_nonemptyset. uf q'. rw H1. rw H5. fprops.
  rw H6. set (qq:=Zo (set_of_functions emptyset emptyset)
        (fun z : Set => increasing_fun z r r')).
  rw H3. rw H5. set (EF:= empty_function).
  assert (Ha: is_function EF). uf EF. app empty_function_function.
  assert (qq = singleton EF).
  assert (Hu: source EF = emptyset). uf EF. uf empty_function. aw.
  assert (Hv: target EF = emptyset). uf EF. uf empty_function. aw.
  set_extens. ufi qq H7. Ztac. awi H8. ee.
  assert (x =EF). app function_exten. ue. ue. rw H10.
  ir. elim (emptyset_pr H12). wr H12. ue. uf qq. rw (singleton_eq H7). Ztac. aw.
  ee. am. am. am. red. ir. eee. nin H;am. nin H0;am. ir.
  elim (emptyset_pr (x:=x0)). wr H6. uf q'. order_tac.
  rw H7. rw cardinal_singleton. simpl. sy; ap succ_zero.
  ir. assert (0 <> p). intuition. nin (nonzero_suc H6). rw H7. rw H3.
  assert (0 + S x - 1 = x). simpl. autoa. rw H8. rww binom_pr0.
  set (qq:=Zo (set_of_functions q' emptyset)
    (fun z : Set => increasing_fun z r r')).
  nin (emptyset_dichot qq). rw H9. rww nat_B_0. app cardinal_zero.
  nin H9. ufi qq H9. Ztac. awi H10. ee. nin (emptyset_dichot q').
  ufi q' H14. rwi H14 H1. elim H5. rwi cardinal_zero H1.
  wri zero_is_emptyset H1. wri nat_B_0 H1.
  app nat_B_inj. sy;am. nin H14. elim (emptyset_pr (x:=W y0 y)). wr H13.
  app inc_W_target. rww H12. autoa.
  ir. assert (0 <> n). intuition. nin (nonzero_suc H4).
  assert (n + p - 1 = x + p). rw H5. rw Sn_is_1plus. wr plus_assoc. autoa.
  rw H6. rwi H5 H2. clear H6. clear H5. clear H3. clear H4.
  assert (is_finite_set (substrate r)). red. rw H1. fprops.
  assert (is_finite_set (substrate r')). red. rw H2. fprops.
  nin (finite_ordered_interval1 H H3). clear H6.
  nin (finite_ordered_interval1 H0 H4). clear H7. nin H6. nin H5.
  cp (inverse_order_isomorphism H5). clear H5. set (x2:= inverse_fun x1) in *.
  set (sr:= substrate r) in *. set (sr':= substrate r') in *.
  set (pp:= nat_to_B p). rwi H1 H7. fold pp in H7.
  cp (cardinal_set_of_increasing_functions3 x p). simpl in H5. wr H5. clear H5.
  set (r3:= interval_Bnatco pp) in *. fold pp. fold r3.
  set (nn:= nat_to_B x) in *. set (r4:= interval_Bnato card_zero nn) in *.
  rwi H2 H6. assert (r4 = (interval_Bnatco (nat_to_B (S x)))).
  uf r4. uf interval_Bnato. uf interval_Bnatco.
  assert (nat_to_B (S x) = succ nn). uf nn. fprops. rw H5. rww interval_co_cc.
  uf nn. fprops. wri H5 H6. clear H5. aw.
  clear H1; clear H2; clear H3; clear H4.
  set (Q1:= Zo (set_of_functions sr sr')
        (fun z : Set => increasing_fun z r r')).
  set (Q2:= Zo (set_of_functions (substrate r3) (substrate r4))
        (fun z : Set => increasing_fun z r3 r4)).
  set (ff:= BL (fun f => (compose (compose x0 f)) x2) Q1 Q2).
  set (E1:= set_of_functions sr sr') in *.
  set (E2:= set_of_functions (substrate r3) (substrate r4)) in *.
  assert (E1 =set_of_functions (target x2) (source x0)).
  red in H6; ee. wr H4. red in H7; ee. wrr H11.
  assert (E2 =set_of_functions (source x2) (target x0)).
  red in H6; ee. wr H6. red in H7; ee. wrr H11.
  assert (Ha:is_function x0). red in H6. ee. fct_tac.
  assert (Hb:is_function x2). red in H7. ee. fct_tac.
  assert(transf_axioms (fun f => compose (compose x0 f) x2) Q1 Q2).
  red. ir. cp (order_isomorphism_increasing H7).
  cp (order_isomorphism_increasing H6).
  assert (increasing_fun c r r'). ufi Q1 H3. Ztac. am.
  assert (target x2 = sr). red in H7; ee; sy; am.
  assert (source x0 = sr'). red in H6; ee; sy; am.
  nin (increasing_compose3 H4 H8 H5). uf Q2. Ztac. ue. nin H12. aw.
  assert (is_function ff). uf ff. app bl_function.
  assert (forall f, inc f Q1 -> W f ff = (compose (compose x0 f) x2)). ir.
  uf ff. rww bl_W.
  assert (forall w, inc w Q1 -> W w (compose3function x2 x0) = W w ff).
  ir. rww H5. ufi Q1 H8. Ztac. rwi H1 H9. awi H9. ee. rww c3f_W.
  exists ff. ee. split. split. am. ir. ufi ff H10. ufi ff H9. awi H9; awi H10.
  wri H8 H11. wri H8 H11.
  assert (surjective x2). red in H7. ee. red in H13. ee; am.
  assert (injective x0). red in H6. ee. red in H14. ee; am.
  nin (c3f_injective H12 H13). assert (source (compose3function x2 x0)= E1).
  rw H1. uf compose3function. aw. rwi H16 H15. app H15. ufi Q1 H9. Ztac. am.
  ufi Q1 H10. Ztac. am. am. am.
  app surjective_pr6. ir. ufi ff H9. awi H9.
  cp (inverse_order_isomorphism H6). cp (inverse_order_isomorphism H7).
  ufi Q2 H9. Ztac.
  cp (order_isomorphism_increasing H10). cp (order_isomorphism_increasing H11).
  cp (increasing_compose3 H15 H13 H14). clear H9. rwi H2 H12. awi H12. ee.
  nin H16. rwi inverse_source H16. rwi inverse_target H16.
  set (x4:= compose (compose (inverse_fun x0) y)(inverse_fun x2)) in *.
  assert (inc x4 Q1). uf Q1. Ztac. rw H1. am. nin H18. am.
  assert (source ff = Q1). uf ff. aw. rw H20. ex_tac. rww (H5 _ H19).
  awi H16. ee. assert (composable x0 x4). red. ee. am. am. sy; am.
  assert (is_function (compose x0 x4)). fct_tac.
  assert (composable (compose x0 x4) x2). red. ee. am. am. aw.
  app function_exten. fct_tac. aw. ue. aw. ue.
  ir. awi H27. rww compose_W.
  assert (inc (W x3 x2) (source (inverse_fun x2))). aw. app inc_W_target.
  assert (inc (W x3 x2) (source x4)). rww H22. awi H28. am. rww compose_W.
  rw (H18 _ H28). nin H7. ee. wr (W_inverse2 H31 H27 (refl_equal (W x3 x2))).
  assert (inc (W x3 y) (target x0)). wr H17. app inc_W_target. ue. nin H6. ee.
  wrr (W_inverse H37 H35 (refl_equal (W (W x3 y) (inverse_fun x0)))).
  uf ff. aw. uf ff. aw.
Qed.

Lemma cardinal_pairs_lt: forall n,
  cardinal(Zo (product Bnat Bnat)
    (fun z=> cardinal_le card_one (P z) &
      cardinal_lt (P z) (Q z) & cardinal_le (Q z) (nat_to_B n)))=
    nat_to_B (binom n 2).
Proof. ir. set (N:= nat_to_B n). set (E:= interval_Bnat card_one N).
  set (T:=Zo (product Bnat Bnat) (fun z=> cardinal_le card_one (P z) &
      cardinal_lt (P z) (Q z) & cardinal_le (Q z) N)).
  nin (le_or_lt 2 n). ir.
  cut (equipotent T (subsets_with_p_elements card_two E)). ir.
  wri cardinal_equipotent H0. rw H0. wr nat_B_2. app binomial7. uf E.
  rww cardinal_interval1a. uf N. fprops.
  set (f:=BL (fun z=> (doubleton (P z) (Q z))) T
    (subsets_with_p_elements card_two E)).
  assert (transf_axioms (fun z=> (doubleton (P z) (Q z))) T
    (subsets_with_p_elements card_two E)). red. uf T. ir. Ztac. ee.
  assert (inc (Q c) Bnat). awi H1. ee; am.
  assert (inc (P c) Bnat). awi H1. ee; am. nin H3.
  uf subsets_with_p_elements. clear H0. Ztac. ap powerset_inc. red. ir.
  assert (inc card_one Bnat). fprops. assert (inc N Bnat). uf N. fprops. uf E.
  nin (doubleton_or H0); rw H10; srw; ee;red; ee. am.
  am. am. am. am. co_tac. am. am. co_tac. am. am. am.
  app cardinal_doubleton. assert (is_function f). uf f. app bl_function.
  exists f. ee. red. ee. red. ee. am. uf f. aw. ir.
  rwii bl_W H4. rwii bl_W H4. ufi T H2. Ztac. ee. clear H2.
  ufi T H3. Ztac. ee. clear H3. nin (doubleton_inj H4). awi H5. awi H2. ee.
  app pair_extensionality. nin H3. rwi H3 H7. rwi H12 H7. nin H10.
  nin H7. elim H13. co_tac.
  app surjective_pr6. uf f. aw. ir.
  ufi subsets_with_p_elements H2. Ztac. clear H2. rwi powerset_inc_rw H3.
  cp (set_of_card_two H4). nin H2. nin H2. ee. assert (inc x E). app H3.
  rw H5. fprops. assert (inc x0 E). app H3. rw H5. fprops.
  assert(exists u, exists v, y = doubleton u v &
    inc u E & inc v E & cardinal_lt u v).
  cp H6; cp H7. ufi E H6. ufi E H7. srwi H6.
  srwi H7. ufi Bnat_le H6. ufi Bnat_le H7. ee.
  cp (Bnat_total_order H15 H13).
  nin H20. red in H20. ee. exists x. exists x0. ee. am. am. am. red. ee. am.
  am. red in H20. ee. exists x0. exists x. ee. rw H5. rw doubleton_symm. tv.
  am. am. red. ee. red in H20; ee. am.
  am. fprops. uf N. fprops. fprops. uf N. fprops. nin H8. nin H8. ee.
  ufi E H9. ufi E H10. srwi H9.
  srwi H10. ufi Bnat_le H9. ufi Bnat_le H10. ee.
  assert (inc (J x1 x2) T). uf T. Ztac. aw. ee. fprops. am. am. aw. ee. am. am.
  am. exists (J x1 x2). ee. am. rw bl_W. aw. sy;am. am. am. fprops.
  uf N. fprops. fprops. uf N. fprops. uf f. aw. uf f. aw. ir.
  rw binom_pr0. rw nat_B_0.
  assert (T=emptyset). app is_emptyset. red. uf T. ir. Ztac. ee.
  assert (inc N Bnat). uf N. fprops.
  assert (inc (Q y) Bnat). awi H1; ee; am.
  assert (inc (P y) Bnat). awi H1; ee; am.
  wri (nat_to_B_pr H6) H3. wri (nat_to_B_pr H6) H4.
  wri (nat_to_B_pr H7) H3. wri (nat_to_B_pr H7) H2. ufi N H4. bwi H4.
  bwi H3. wri nat_B_1 H2. bwi H2.
  cp (le_lt_trans _ _ _ H4 H). cp (lt_n_Sm_le _ _ H8).
  cp (lt_le_trans _ _ _ H3 H9). cp (lt_n_Sm_le _ _ H10).
  cp (le_trans _ _ _ H2 H11). elim (le_Sn_O 0 H12). rww H0.
  rww cardinal_zero. auto.
Qed.

Lemma binom_2plus: forall n, binom (S n) 2= Nquo(n *(S n)) 2.
Proof. ir. rw binom2. rww mult_comm.
Qed.

Lemma binom_2plus0: forall n, binom (S n) 2= (binom n 2) +n.
Proof. ir. simpl. rww binom1.
Qed.

Lemma cardinal_pairs_le: forall n,
  cardinal(Zo (product Bnat Bnat)
    (fun z=> cardinal_le card_one (P z) &
      cardinal_le (P z) (Q z) & cardinal_le (Q z) (nat_to_B n)))=
    nat_to_B (binom (S n) 2).
Proof. ir. set (E1:= Zo (product Bnat Bnat) (fun z =>
         cardinal_le card_one (P z) &
         cardinal_le (P z) (Q z) & cardinal_le (Q z) (nat_to_B n))).
  set (E2:= Zo (product Bnat Bnat) (fun z =>
         cardinal_le card_one (P z) &
         cardinal_lt (P z) (Q z) & cardinal_le (Q z) (nat_to_B n))).
  assert (cardinal E2 = nat_to_B (binom n 2)). uf E2. app cardinal_pairs_lt.
  assert (sub E2 E1). uf E1. uf E2. red. ir. Ztac. eee. nin H3; am.
  cp (cardinal_complement H0). wr H1. rw H.
  cut (cardinal (complement E1 E2) = nat_to_B n). ir. rw H2. bw.
  rww binom_2plus0.
  assert (forall x, inc x (complement E1 E2) = (is_pair x & P x = Q x &
    cardinal_le card_one (P x) & cardinal_le (P x) (nat_to_B n) &
    inc (P x) Bnat)). ir. app iff_eq. ir. srwi H2.
  nin H2. ufi E1 H2. cp (Z_all H2). nin H4. awi H4.
  nin (equal_or_not (P x) (Q x)). wri H6 H5. intuition.
  assert (cardinal_lt (P x) (Q x)). red. intuition. elim H3. uf E2. clear H2.
  Ztac. aw. intuition. ir. ee. rw inc_complement. uf E1. uf E2. split. Ztac. aw.
  wr H3. intuition. wr H3. intuition. red. ir. Ztac. ee. red in H10. ee.
  contradiction. nin (le_or_lt 1 n). ir.
  set (T:= interval_Bnat card_one (nat_to_B n)).
  assert (nat_to_B n = cardinal T). uf T. rww cardinal_interval1a. fprops.
  rw H4. aw. set (f:= BL P (complement E1 E2) T).
  assert (transf_axioms P (complement E1 E2) T). red. ir. uf T.
  rwi H2 H5. ee. srw. uf Bnat_le. ee; fprops. fprops. fprops.
  assert (is_function f). uf f. app bl_function. exists f. ee. red; ee.
  red. ee. am. uf f. simpl. ir. rwii bl_W H9.
  rwii bl_W H9. awi H7. rwi H2 H7. awi H8. rwi H2 H8. ee.
  app pair_extensionality.
  wrr H14; wrr H10. awi H8. am. awi H7. am. app surjective_pr6. uf f. aw.
  ir. ufi T H7. srwi H7. ufi Bnat_le H7.
  assert (inc (J y y) (complement E1 E2)). rww H2. aw. intuition.
  exists (J y y). split. am. rww bl_W. aw. fprops. fprops. uf f.
  aw. uf f. aw. red in H3. cp (le_S_n _ _ H3). cp (le_n_O_eq _ H4). wr H5.
  rw nat_B_0. uf card_zero. assert ((complement E1 E2)=emptyset).
  app is_emptyset. red. ir. rwi H2 H6. ee.
  assert (cardinal_le card_one (nat_to_B n)). co_tac.
  wri nat_B_1 H11. bwi H11. wri H5 H11. elim (le_Sn_O 0 H11). ue.
Qed.

Lemma sum_of_i: forall n, fct_sum (fun i=> i) n = binom n 2.
Proof. ir. induction n. tv. aw. rw IHn. simpl. rww binom1.
Qed.

Lemma sum_of_i2: forall n,
  cardinal_sum (L (interval_Bnat card_one (nat_to_B n)) (fun i=>i)) =
  nat_to_B(binom (S n) 2).
Proof. ir. set (E:= interval_Bnat card_one (nat_to_B n)).
  assert (Ha:inc (nat_to_B n) Bnat). fprops. assert (inc card_one Bnat). fprops.
  wr cardinal_pairs_le. set (X:=Zo (product Bnat Bnat) (fun z =>
  cardinal_le card_one (P z) &
  cardinal_le (P z) (Q z) & cardinal_le (Q z) (nat_to_B n))).
  set(f:= L E (fun k => Zo X (fun z => Q z = k))).
  assert (X = unionb f). set_extens. uf f. rw unionb_rw. bw. exists (Q x).
  assert (inc (Q x) E). cp H0. ufi X H1. Ztac. ee. uf E. awi H2.
  srw. uf Bnat_le. intuition. co_tac.
  ee. am. bw. Ztac. ufi f H0.
  srwi H0. nin H0. bwi H0. ee. Ztac. am. ee. am.
  assert (f= disjoint_union_fam (L E (fun i => interval_Bnat card_one i))).
  uf f. uf disjoint_union_fam. bw. app L_exten1.
  ir. bw. ufi E H1. srwi H1. ufi Bnat_le H1. ee.
  set_extens. Ztac. ufi X H8. clear H7. Ztac. ee. awi H7. aw. ee. am.
  srw. uf Bnat_le. intuition. rwi H9 H11. am. am.
  awi H7. ee. srwi H8. ufi Bnat_le H8. ee.
  Ztac. uf X. Ztac. aw. ee. am. am. ue.
  ee. am. ue. ue. fprops. am. fprops. fprops. uf cardinal_sum.
  assert (X = disjoint_union (L E (fun i => interval_Bnat card_one i))).
  uf disjoint_union. wrr H1. rw H2. aw.
  app equipotent_disjoint_union1. gprops. gprops. bw. bw. ir. bw.
  ufi E H3. srwi H3. ufi Bnat_le H3. ee.
  wr cardinal_equipotent. rw cardinal_interval1a. fprops. am. fprops. fprops.
Qed.

Lemma fct_sum_const1: forall f n m, (forall i, i<n -> f i = m) ->
  fct_sum f n = n *m.
Proof. intros f n m. induction n. tv. aw. ir. rw IHn. rw plus_comm. rww H.
  autoa. ir. app H. autoa.
Qed.

Lemma sum_of_i3: forall n, fct_sum (fun i=> i) n = binom n 2.
Proof. ir. case n. tv. ir. rw binom2. set (m:= S n0).
  set (sn := fct_sum (fun i => i) m). cut(sn + sn = m * n0). ir.
  app Ndivides_pr2. rw mult_comm. wrr H. simpl. autoa.
  cp (fct_sum_plus (fun i => i) (fun i => (m - i -1)) m).
  assert (forall i, i< m -> i + (m - i - 1) = n0). ir. ufi m H0. uf m.
  rww minus_SnSi. sy. ap le_plus_minus. autoa. wr (fct_sum_const1 _ H0).
  wr H. assert (sn = fct_sum (fun i => (m - i -1)) m). uf sn.
  cp (fct_sum_rev (fun i : nat => i) m). simpl in H0. am. wrr H1.
Qed.

Definition set_of_functions_sum_le E n:=
  Zo (set_of_functions E (interval_Bnat card_zero n))
  (fun z=> cardinal_le(cardinal_sum (P z)) n).

Definition set_of_functions_sum_eq E n:=
  Zo (set_of_functions E (interval_Bnat card_zero n))
  (fun z=> (cardinal_sum (P z)) = n).

Lemma set_of_functions_sum0: forall f,
  (forall a b, inc (f a b) Bnat) ->
  (forall a, f 0 a = card_one) ->
  (forall a , f a 0 = card_one) ->
  (forall a b, f (S a) (S b) = card_plus (f (S a) b) (f a (S b))) ->
  forall a b, f a b = nat_to_B(binom (a+b) a).
Proof. intros f H H0 H1 H2. set (g:= fun a b => cardinal_nat (f a b)).
  cut (forall a b, g a b = (binom (a + b) a)). ir. wrr H3. uf g. aw.
  assert (forall a, g 0 a = 1). ir. uf g. rw H0. wr nat_B_1.
  rww nat_to_B_pr1.
  assert (forall a, g a 0 = 1). ir. uf g. rw H1. wr nat_B_1.
  rww nat_to_B_pr1.
  assert (forall a b, g (S a) (S b) = (g (S a) b) + (g a (S b))). uf g.
  ir. rw H2. cp (H (S a) b). cp (nat_to_B_pr H5).
  cp (H a (S b)). cp (nat_to_B_pr H7). wr H6. wr H8. wr nat_B_plus.
  rww nat_to_B_pr1. rw nat_to_B_pr. rw nat_to_B_pr. tv. am. am.
  intro a. induction a. simpl. ir. rw H3. induction b; tv.
  ir. induction b. assert (S a +0 = S a). autoa. rw H6.
  rw binom_symmetric. assert (S a - S a = 0). autoa. rw H7. tv. auto.
  rw H5. rw IHb. rw IHa. set (c:= S b). set (q:= binom (S a + c) (S a)).
  simpl in q. tv. assert(a + c = S a + b). uf c. sy. ap plus_Snm_nSm. wrr H6.
Qed.

Lemma set_of_functions_sum1: forall E x n,
  inc n Bnat -> is_finite_set E -> ~ (inc x E) ->
  equipotent (set_of_functions_sum_le E n)
  (set_of_functions_sum_eq (tack_on E x) n).
Proof. ir. set (K:= interval_Bnat card_zero n).
  set (f:= fun z=> tack_on_f z x (card_sub n (cardinal_sum (graph z)))).
  assert(forall z, is_function z -> source z = E -> target z = K ->
    (cardinal_le (cardinal_sum (graph z)) n) ->
    (is_function (f z) & source (f z) = tack_on E x & target (f z) = K &
      (cardinal_sum (graph (f z)) = n))).
  ir. assert (is_function (f z)). uf f. app tack_on_function. rww H3. split.
  am. set (t:= cardinal_sum (graph z)). fold t in H5.
  assert (inc t Bnat). rwi inc_Bnat H. cp (le_int_is_int H H5). bw. tv.
  assert (inc t K). uf K. rww interval_Bnat_pr0.
  assert (inc (card_sub n t) Bnat). app Bnat_stable_sub.
  assert (inc (card_sub n t) K). uf K. rww interval_Bnat_pr0.
  app sub_le_symmetry.
  split. uf f. tv. uf tack_on_f. aw. rww H3. split. uf f. uf tack_on.
  uf tack_on_f. aw.
  rw H4. fold t. set_extens. rwi tack_on_inc H11. nin H11. am. rww H11. fprops.
  uf f. cp (partition_tack_on H1).
  set (g:= variantLc E (singleton x)).
  assert(partition_fam g (domain (graph (f z)))). red in H6. ee. wr H13.
  uf f. uf tack_on_f. aw. uf g. rww H3.
  assert (fgraph (graph (f z))). fprops. cp (cardinal_sum_assoc H13 H12).
  ufi f H14. rw H14. clear H14. uf tack_on_f. rw corresp_graph. uf g.
  assert (Ha:V x (tack_on (graph z) (J x (card_sub n t))) = W x (f z)).
  uf f. uf W. uf tack_on_f. rw corresp_graph. tv. bw. rw card_plus_pr0. bw.
  fold t. rww trivial_cardinal_sum3. rw Ha.
  assert (restr (tack_on (graph z) (J x (card_sub n t))) E= (graph z)).
  uf restr. set_extens. Ztac. rwi tack_on_inc H15. nin H15. am. rwi H15 H16.
  awi H16. elim H1. am. Ztac. fprops. wr H3. app inc_pr1graph_source1. rw H14.
  fold t. uf f. rw tack_on_W_out. uf t. app card_sub_pr. am. rww H3.
  ufi f H13. ufi tack_on_f H13. rwi corresp_graph H13. am. aw.

  exists (card_sub n t). uf tack_on_f. fprops. red in H13. ee.
  ufi f H13. ufi tack_on_f H13. rwi corresp_graph H13. app H13. rw Ha. uf f.
  rw tack_on_W_out. fold t. fprops. am. rww H3.
  set (g:= BL f (set_of_functions_sum_le E n)
    (set_of_functions_sum_eq (tack_on E x) n)).
  assert (transf_axioms f (set_of_functions_sum_le E n)
    (set_of_functions_sum_eq (tack_on E x) n)).
  red. ir. ufi set_of_functions_sum_le H3. Ztac. clear H3. awi H4. ee.
  cp (H2 _ H3 H4 H6 H5). ee. uf set_of_functions_sum_eq. Ztac. fold K. aw.
  eee.
  assert (is_function g). uf g. app bl_function.
  assert (surjective g). uf g. app bl_surjective. ir.
  ufi set_of_functions_sum_eq H5. Ztac. clear H5.
  awi H6. ee.
  set (x1:= restriction y E). assert (is_function x1). uf x1.
  app restriction_function. rw H6. fprops.
  assert (Ha: source x1 = E). uf x1. uf restriction. aw.
  assert (Hb: target x1 = K). uf x1. uf restriction. aw.
  assert (inc x1 (set_of_functions E (interval_Bnat card_zero n))). aw. eee.
  assert (cardinal_le (cardinal_sum (graph x1)) n).
  assert (graph x1 = restr (graph y) E). uf x1. uf restriction. aw. rw H11.
  assert (n =cardinal_sum (graph y)). wr H7. tv. rw H12.
  app sum_increasing1. fprops. ir. change (is_cardinal (W x0 y)).
  assert (inc x0 (source y)). red in H5. ee. ue. cp (inc_W_target H5 H14).
  rwi H8 H15. srwi H15. ufi Bnat_le H15. ee. fprops.
  fprops. am. red in H5. ee. wr H14. rw H6. fprops.
  assert (inc x1 (set_of_functions_sum_le E n)).
  uf set_of_functions_sum_le. Ztac. exists x1. split. am.
  cp (H2 _ H9 Ha Hb H11). ee. app function_exten.
  ue. ue. ir. rwi H14 H17. rwi tack_on_inc H17. nin H17. uf f. rw tack_on_W_in.
  uf x1. rw restriction_W. tv. am. rw H6. fprops. am. am. rww Ha. rww Ha.
  rw H17. uf f. rww tack_on_W_out. uf x1. uf restriction. aw.
  sy. app card_sub_pr2. assert (inc x (source y)). rw H6. fprops.
  cp (inc_W_target H5 H18). rwi H8 H19. srwi H19.
  ufi Bnat_le H19. ee. fprops. fprops. am. app finite_sum_finite.
  red. assert (restr (graph y) E = graph x1). uf x1. uf restriction.
  aw. rw H18. ee.
  fprops. ir. change (inc (W i x1) Bnat). assert (inc i (source x1)).
  red in H10. ee. red in H9. ee. rww H21. cp (inc_W_target H9 H20).
  rwi Hb H21. ufi K H21. ap (sub_interval_Bnat H21). red in H9. ee. wrr H20.
  ue. cp (partition_tack_on H1). set (h:= variantLc E (singleton x)).
  assert(partition_fam h (domain (graph y))). red in H5. ee. wr H20. uf h.
  rww H6. assert (fgraph (graph y)). fprops. cp (cardinal_sum_assoc H20 H19).
  wr H7. ufi graph H21. rw H21. clear H21. uf h. bw. rw card_plus_pr0. bw.
  rw card_plus_commutative. rww trivial_cardinal_sum3. red in H5. ee.
  ufi graph H22. wr H22. rw H6. fprops.
  change (is_cardinal (W x y)). assert (inc (W x y) Bnat).
  assert (inc x (source y)). rw H6. fprops. cp (inc_W_target H5 H21).
  rwi H8 H22. srwi H22. ufi Bnat_le H22. ee. fprops. fprops. am. fprops. ue.
  assert (injective g). uf g. app bl_injective. ir.
  ufi set_of_functions_sum_le H6. ufi set_of_functions_sum_le H7.
  Ztac. clear H7. Ztac. awi H9; awi H7. ee. wri H15 H13. wri H12 H1.
  wri H14 H12. ap (tack_on_f_injective H7 H9 H13 H12 H1 H8).
  exists g. ee. red. ir. ee. am. am. uf g. aw. uf g. aw.
Qed.

Lemma set_of_functions_sum2: forall E n,
  inc n Bnat -> is_finite_set E ->
  equipotent (complement (set_of_functions_sum_le E (succ n))
    (set_of_functions_sum_eq E (succ n)))
  (set_of_functions_sum_le E n).
Proof. ir. set (E1:= set_of_functions_sum_le E (succ n)).
  set (E2:= set_of_functions_sum_eq E (succ n)).
  set (E3:= set_of_functions_sum_eq E n).
  set (I1:= interval_Bnat card_zero (succ n)).
  set (I2:= interval_Bnat card_zero n).
  assert (sub I2 I1).
  uf I1. uf I2. red. ir. rwi interval_Bnat_pr0 H1. rw interval_Bnat_pr0.
  apply cardinal_le_transitive with n. am. app is_less_than_succ. fprops.
  fprops. am.
  set (f:= fun z => restriction2 z E I2).
  assert (forall z x, is_function z -> target z = I1 ->
    inc x (source z) -> inc (W x z) Bnat).
  ir. cp (inc_W_target H2 H4). rwi H3 H5. ufi I1 H5.
  ap (sub_interval_Bnat H5).
  assert (forall z, is_function z -> source z = E -> target z = I1 ->
    cardinal_le (cardinal_sum (graph z)) (succ n) ->
    ~ (cardinal_sum (graph z) = succ n) ->
    (is_function (f z) & source (f z) = E & target (f z) = I2 &
      graph (f z) = graph z &
      cardinal_le (cardinal_sum (graph (f z))) n)).
  ir. set (t := cardinal_sum (graph z)) in *.
  assert (inc t Bnat). bw. assert (inc (succ n) Bnat). fprops.
  rwi inc_Bnat H8. Bnat_tac. assert (cardinal_lt t (succ n)).
  red. split;am. srwi H9.
  assert (forall i, inc i (source z) -> cardinal_le (W i z) n).
  ir. cp (partition_complement H10).
  assert (fgraph (graph z)). fprops. assert (source z = domain (graph z)).
  red in H3. ee. am. rwi H13 H11.
  cp (cardinal_sum_assoc H12 H11). bwi H14.
  rwi card_plus_pr0 H14. bwi H14. rwi trivial_cardinal_sum3 H14.
  apply cardinal_le_transitive with (cardinal_sum (graph z)).
  rw H14. rw card_plus_commutative. uf W. app sum_increasing3.
  change (is_cardinal (W i z)). assert (inc (W i z) Bnat). app H2. fprops.
  uf cardinal_sum. fprops. exact H9. fprops. ue.
  change (is_cardinal (W i z)). assert (inc (W i z) Bnat). app H2. fprops.
  assert (restriction2_axioms z E I2). red. ee. am. rw H4. fprops. rw H5. am.
  red. uf image_by_fun. ir. awi H11. nin H11. ee.
  wri H4 H11. cp (W_pr H3 H12). cp (H10 _ H11).
  uf I2. rw interval_Bnat_pr0. ue. am. fprops.
  assert (is_function (f z)). uf f. app restriction2_function.
  assert (Hc:graph (f z) = graph z). uf f. uf restriction2. aw.
  set_extens. inter2tac. app intersection2_inc. wr H4. nin H3.
  cp (corresp_propb H3). app H15. eee. uf f. uf restriction2. aw. uf f.
  uf restriction2. aw. fprops.
  set (g:= BL f (complement E1 E2) (set_of_functions_sum_le E n)).
  assert (forall z, inc z (complement E1 E2) ->
    (is_function z & source z = E & target z = I1 &
    cardinal_le (cardinal_sum (graph z)) (succ n) &
       cardinal_sum (graph z) <> succ n)).
  ir. srwi H4. nin H4. ufi E1 H4. ufi E2 H5.
  ufi set_of_functions_sum_le H4. ufi set_of_functions_sum_eq H5.
  Ztac. clear H4. awi H6. eee. dneg. Ztac. eee. aw. eee.
  assert (transf_axioms f (complement E1 E2) (set_of_functions_sum_le E n)).
  red. ir. cp (H4 _ H5). ee. cp (H3 _ H6 H7 H8 H9 H10). ee.
  uf set_of_functions_sum_le. Ztac. aw. eee. exists g. ee. uf g.
  app bl_bijective.
  ir. nin (H4 _ H7). nin (H4 _ H6). ee.
  cp (H3 _ H9 H10 H16 H17 H18). cp (H3 _ H11 H12 H13 H14 H15). ee.
  app function_exten1. wr H23. rww H8. ue.
  ir. ufi set_of_functions_sum_le H6. Ztac. clear H6. cp H7. awi H7. ee.
  set (z := corresp E I1 (graph y)). assert (is_function z). uf z.
  app is_function_pr. fprops. apply sub_trans with (target y).
  red in H7. ee. fprops. rww H10. red in H7. ee. wrr H12.
  sy; am. assert (P z = P y). uf z. aw. assert (inc z (complement E1 E2)).
  srw. ee. uf E1. uf set_of_functions_sum_le. Ztac. aw. ee. am. uf z. aw.
  uf z. aw. apply cardinal_le_transitive with n. ue. app is_less_than_succ.
  fprops. red. ir. ufi E2 H13. ufi set_of_functions_sum_eq H13. Ztac.
  rwi H12 H15. rwi H15 H8. rwi inc_Bnat H. red in H. ee.
  cp (is_less_than_succ H). elim H16. sy. co_tac.
  ex_tac. cp (H5 _ H13). ufi set_of_functions_sum_le H14. Ztac. awi H15. ee.
  assert (sub (target y) (target z)). uf z. aw. rww H10.
  app function_exten1. uf f. uf restriction2. aw.
  uf graph. set_extens. cp (intersection2_first H20). wrr H12.
  app intersection2_inc. rww H12. aw. red in H7. nin H7. nin H7.
  red in H22. cp (H22 _ H20). awi H23. eee. rww H18. sy; am. uf g. aw.
  uf g; aw.
Qed.

Lemma set_of_functions_sum3: forall E,
  cardinal (set_of_functions_sum_le E card_zero) = card_one.
Proof. ir. set (E2:= interval_Bnat card_zero card_zero).
  set (f:= BL (fun x=> card_zero) E E2).
  assert (set_of_functions_sum_le E card_zero = singleton f).
  assert (E2= singleton card_zero). uf E2. set_extens. rwi interval_Bnat_pr0 H.
  rw (zero_smallest2 H). fprops. fprops. rw (singleton_eq H).
  rw interval_Bnat_pr0. fprops. fprops.
  assert (is_function (BL (fun x=> card_zero) E E2)). app bl_function.
  red. ir. rw H. fprops. set_extens. ufi set_of_functions_sum_le H1. Ztac.
  awi H2. ee. assert (x = f). app function_exten. uf f. aw. uf f. aw.
  uf f. ir. rw bl_W. assert (Ha: domain (graph x) = source x).
  red in H2. ee. sy; am.
  assert (fgraph (graph x)). fprops.
  assert (forall a, inc a (domain (graph x)) -> is_cardinal (V a (graph x))).
  ir. change (is_cardinal (W a x)). assert (inc (W a x) (target x)).
  app inc_W_target. ue. rwi H5 H9. ufi E2 H. rwi H H9.
  rw (singleton_eq H9). fprops.
  assert (sub (singleton x0) (domain (graph x))). ue. red. ir. awi H9. ue.
  cp (sum_increasing1 H7 H8 H9). rwi trivial_cardinal_sum3 H10.
  cp (cardinal_le_transitive H10 H3). app Bnat_zero_smallest1. red. uf W. ee.
  bw. apply le_int_is_int with card_zero. fprops. am.
  fprops. am. fprops. ue. app H8. ue.
  red. ir. rw H. fprops. ue. ue. awi H1. rw H1.
  uf set_of_functions_sum_le. Ztac. aw. ee. uf f. app bl_function. red. ir.
  rw H. fprops. uf f. aw. uf f. aw.
  assert (P f = cst_graph E card_zero). uf f. uf BL. aw. rw H2.
  rw sum_of_same1. rw card_mult_commutative. rw zero_prod_absorbing. fprops.
  rw H. app cardinal_singleton.
Qed.

Lemma set_of_functions_sum4: forall n, is_cardinal n->
    cardinal (set_of_functions_sum_le emptyset n) = card_one.
Proof. ir. rename H into Hn.
  set (E2:= interval_Bnat card_zero n).
  set (f:= (BL (fun x=> card_zero) emptyset E2)).
  assert (set_of_functions_sum_le emptyset n = singleton f).
  assert (is_function (BL (fun x=> card_zero) emptyset E2)). app bl_function.
  red. ir. elim (emptyset_pr H). set_extens. ufi set_of_functions_sum_le H0.
  Ztac. awi H1. ee. assert (x = f). ee. app function_exten.
  uf f. aw. uf f. aw. ir. rwi H3 H5. elim (emptyset_pr H5). rw H5. fprops.
  awi H0. rw H0. uf set_of_functions_sum_le. Ztac. aw. uf f. ee.
  app bl_function. red. ir. elim (emptyset_pr H1). aw. aw.
  rw trivial_cardinal_sum. app zero_smallest. uf f. uf BL. aw. rw H.
  app cardinal_singleton.
Qed.

Lemma set_of_functions_sum_pr: forall n h,
  let intv:= fun h => (interval_co_0a (nat_to_B h)) in
    let sle:= fun n h => set_of_functions_sum_le (intv h) (nat_to_B n) in
      let seq := fun n h => set_of_functions_sum_eq (intv h) (nat_to_B n) in
        let A:= fun n h => cardinal (sle n h) in
          let B:= fun n h => cardinal (seq n h) in
            (A n h = B n (S h) & A n h = nat_to_B(binom (n+h) n)).
Proof. ir. uf A; uf B.
  assert (Hq: forall a b, inc (cardinal (sle a b)) Bnat). ir. bw.
  set (E:= intv b). set (nn:= nat_to_B a). uf sle. fold E; fold nn.
  assert (is_finite_set E). uf E. uf intv. app finite_set_interval_co. fprops.
  set (t3:= set_of_functions_sum_le E nn) in *.
  set (E2:= interval_Bnat card_zero nn).
  assert (is_finite_c (cardinal E2)). uf E2.
  change (is_finite_set (interval_Bnat card_zero nn)).
  app finite_set_interval_Bnat. red. ee. fprops. fprops. uf nn. fprops.
  app zero_smallest. fprops. uf nn. fprops.
  set (E1:=set_of_functions E E2). assert (is_finite_set E1).
  red. uf E1. change (is_finite_c (card_pow E2 E)).
  assert (card_pow E2 E = card_pow (cardinal E2) (cardinal E)).
  app card_pow_pr. fprops. fprops. rw H1. wr inc_Bnat. app Bnat_stable_pow.
  bw. bw. assert (sub t3 E1). uf t3.
  uf set_of_functions_sum_le. app Z_sub. cp (sub_smaller H2). red in H1.
  Bnat_tac.
  assert (Ht:forall a, cardinal (sle 0 a) = card_one). ir.
  uf sle. rw nat_B_0. app set_of_functions_sum3.
  assert (Hu:forall a, cardinal (sle a 0) = card_one). ir.
  uf sle. assert (intv 0 = emptyset). uf intv. rw nat_B_0.
  app emptyset_interval_00. rw H. app set_of_functions_sum4. fprops.
  assert (forall a b, cardinal (sle a b) = cardinal (seq a (S b))). ir.
  aw. uf sle. uf seq.
  set (E:= intv b). cp (inc_nat_to_B b). cp (interval_co_pr4 H). ee.
  set (hh:= nat_to_B b) in *. assert (E= interval_co_0a hh). uf E. uf intv.
  tv. wri H2 H0. wri H2 H1. uf intv. assert (nat_to_B (S b) = succ hh).
  uf hh. aw. rw H3. wr H0. app set_of_functions_sum1. fprops. uf E.
  uf intv. app finite_set_interval_co.
  assert (forall a b, sub (seq (S a) b) (sle (S a) b)). ir.
  uf sle. uf seq. set (E:= intv b). uf set_of_functions_sum_le.
  uf set_of_functions_sum_eq. red. ir. Ztac. clear H0. Ztac. rw H2. fprops.
  assert (forall a b, cardinal (sle (S a) b) =
   card_plus (cardinal (seq (S a) b)) (cardinal (sle a b))). ir.
  uf sle. uf seq. set (E:= intv b). set (nn:= nat_to_B a).
  assert (succ nn = nat_to_B (S a)). uf nn. fprops. wr H1.
  assert (inc nn Bnat). uf nn. fprops. assert (is_finite_set E). uf E.
  uf intv. app finite_set_interval_co. fprops.
  cp (set_of_functions_sum2 H2 H3).
  set (t1:= set_of_functions_sum_le E (succ nn)) in *.
  set (t2:= set_of_functions_sum_eq E (succ nn)) in *.
  set (t3:= set_of_functions_sum_le E nn) in *.
  assert (sub t2 t1). uf t2; uf t1. cp (H0 a b). ufi seq H5.
  ufi sle H5. rww H1. set (n2:= cardinal t1). assert (cardinal t1 = n2). tv.
  set (p2:=cardinal t2). assert (cardinal t2 = p2). tv.
  assert (inc n2 Bnat). uf n2.
  set (E2:= interval_Bnat card_zero (succ nn)).
  assert (is_finite_c (cardinal E2)). uf E2.
  change (is_finite_set (interval_Bnat card_zero (succ nn))).
  app finite_set_interval_Bnat. red. ee. fprops. fprops.
  app zero_smallest. fprops.
  set (E1:=set_of_functions E E2). assert (is_finite_set E1).
  red. uf E1. change (is_finite_c (card_pow E2 E)).
  assert (card_pow E2 E = card_pow (cardinal E2) (cardinal E)).
  app card_pow_pr. fprops. fprops. rw H9. wr inc_Bnat. app Bnat_stable_pow.
  bw. bw. assert (sub t1 E1). uf t1.
  uf set_of_functions_sum_le. app Z_sub. cp (sub_smaller H10). bw.
  red in H9. app (le_int_is_int H9 H11). assert (inc p2 Bnat).
  cp (sub_smaller H5). bw. bwi H8. wri H6 H8.
  app (le_int_is_int H8 H9). cp (cardinal_complement1 H8 H9 H6 H7 H5).
  wri cardinal_equipotent H4. rwi H4 H10. rw H10. sy. app card_sub_pr.
  cp (sub_smaller H5). am.
  assert (forall a b, cardinal (sle (S a) (S b)) =
    card_plus (cardinal (sle (S a) b)) (cardinal (sle a (S b)))).
  ir. rw (H1 a (S b)). wrr H.
  split. app H. app (set_of_functions_sum0 (fun a b => cardinal (sle a b))).
Qed.

Definition set_of_functions_sum_le_int p n :=
  set_of_functions_sum_le (interval_Bnat card_zero p) n.

Definition set_of_increasing_functions_int p n :=
  (Zo (set_of_functions (interval_Bnat card_zero p) (interval_Bnat card_zero n))
    (fun z => increasing_fun z
      (interval_Bnato card_zero p)
      (interval_Bnato card_zero n))).

Lemma card_set_of_increasing_functions_int : forall p n,
  cardinal (set_of_increasing_functions_int (nat_to_B p)(nat_to_B n)) =
  nat_to_B(binom (n+p+1) (p+1)).
Proof. ir. cp (cardinal_set_of_increasing_functions3 n (p+1)).
  assert (n + (p + 1) = n+ p +1). autoa. wr H0. simpl in H.
  uf set_of_increasing_functions_int.
  set (E1:= interval_Bnato card_zero (nat_to_B n)) in *.
  assert (interval_Bnat card_zero (nat_to_B n) = substrate E1). uf E1.
  rw interval_Bnato_substrate. tv. fprops. fprops. rw H1.
  set (E2:= interval_Bnato card_zero (nat_to_B p)).
  assert (interval_Bnat card_zero (nat_to_B p) = substrate E2). uf E2.
  rw interval_Bnato_substrate. tv. fprops. fprops. rw H2.
  set (E3:=interval_Bnatco (nat_to_B (p + 1))) in *. assert (E2 = E3).
  uf E2; uf E3. uf interval_Bnato. uf interval_Bnatco.
  rw interval_co_cc. wr nat_B_S. rww Sn_is_plus1. fprops. ue.
Qed.

Lemma double_restrc: forall f n p, fgraph f -> inc p Bnat ->
  cardinal_lt n p ->
  domain f = interval_Bnat card_zero p ->
  restr (restr f (interval_Bnat card_zero (succ n)))
     (interval_Bnat card_zero n) =
     restr f (interval_Bnat card_zero n).
Proof. ir. set (E1:= interval_Bnat card_zero n) in *.
  set (E2:= interval_Bnat card_zero (succ n)) in *.
  set (E3:= interval_Bnat card_zero p) in *.
  assert (inc n Bnat). nin H1. Bnat_tac.
  assert (cardinal_le (succ n) p). srw. fprops. fprops.
  assert (inc (succ n) Bnat). fprops.
  assert (sub E1 E2). uf E1; uf E2. app interval_cc_0a_increasing.
  app is_less_than_succ. fprops.
  assert (sub E2 E3). uf E2; uf E3. app interval_cc_0a_increasing.
  assert (domain (restr f E1) = E1). rww restr_domain1. rw H2.
  app (sub_trans H6 H7).
  assert (domain (restr f E2) = E2). rww restr_domain1. rww H2.
  app fgraph_exten. fprops. fprops.
  rw restr_domain1. sy; am. fprops. ue.
  rw restr_domain1. ir. rw restr_ev. rw restr_ev. rw restr_ev. tv. am.
  rww H2. app (sub_trans H6 H7). am. fprops. ue. app H6.
  fprops. ue. am. fprops. ue.
Qed.

Lemma induction_on_sum3: forall f m,
  is_function f -> inc m Bnat ->
  source f = interval_Bnat card_zero m ->
  (forall a, inc a (source f) -> is_cardinal (W a f)) ->
  (cardinal_sum (restr (graph f) (interval_Bnat card_zero card_zero))
    = (W card_zero f)
    & (forall n, cardinal_le n m ->
      card_plus (cardinal_sum (restr (graph f) (interval_co_0a n))) (W n f)
      = cardinal_sum (restr (graph f) (interval_co_0a (succ n))))).
Proof. ir. split.
  assert (interval_Bnat card_zero card_zero = singleton card_zero).
  set_extens. rwi interval_Bnat_pr0 H3. rw (zero_smallest2 H3). fprops. fprops.
  rw interval_Bnat_pr0. rw (singleton_eq H3). fprops. fprops. rw H3.
  assert (fgraph (graph f)). fprops. nin H. nin H5. ufi W H2. rwi H6 H2.
  assert (inc card_zero (domain (graph f))). wr H6. rw H1.
  rww interval_Bnat_pr0. fprops. rww trivial_cardinal_sum3. app H2.
  ir. assert (inc n Bnat). Bnat_tac.
  cp (partition_tack_on_intco H4).
  set (g:= restr (graph f) (interval_co_0a (succ n))).
  assert (sub (interval_co_0a (succ n)) (domain (graph f))).
  nin H. ee. wr H7. rw H1. wr interval_co_cc. app interval_cc_0a_increasing. am.
  assert (fgraph g). uf g. fprops. fprops.
  assert (domain g = (interval_co_0a (succ n))). uf g. rw restr_domain.
  rw intersection2comm. wrr intersection2_sub. fprops.
  assert (W n f = V n g). uf g. rww restr_ev. fprops. rww interval_co_0a_pr3.
  fprops. rww H9.
  wri H8 H5. rw (cardinal_sum_assoc H7 H5). bw. rw card_plus_pr0. bw.
  rw trivial_cardinal_sum3.
  assert (restr (graph f) (interval_co_0a n) = restr g (interval_co_0a n)).
  uf g. uf restr. set_extens. Ztac. clear H10. Ztac. Ztac.
  rw interval_co_0a_pr3. srwi H12. nin H12. am. am. am.
  Ztac. clear H10. Ztac. am. rww H10. am. rw H8.
  rw interval_co_0a_pr3. fprops. am. wr H9. app H2. rw H1.
  rww interval_Bnat_pr0.
Qed.

Definition sum_to_increasing_fun y :=
  fun i => cardinal_sum (restr (graph y) (interval_Bnat card_zero i)).

Definition sum_to_increasing_fct y n p :=
  BL (sum_to_increasing_fun y)
  (interval_Bnat card_zero p) (interval_Bnat card_zero n).

Lemma sum_to_increasing1: forall y n p,
  inc n Bnat -> inc p Bnat ->
  inc y (set_of_functions_sum_le_int p n) ->
  transf_axioms (sum_to_increasing_fun y)
    (interval_Bnat card_zero p)
    (interval_Bnat card_zero n).
Proof. ir. ufi set_of_functions_sum_le_int H1.
  ufi set_of_functions_sum_le H1. Ztac. clear H1. awi H2. ee. red. ir.
  rww interval_Bnat_pr0.
  assert (source y = domain (graph y)). nin H1;ee;am.
  assert (fgraph (graph y)). fprops.
  assert (forall u, inc u (domain (graph y)) -> inc (V u (graph y)) Bnat).
  ir. assert (inc (W u y) (target y)). wri H6 H8. fprops.
  rwi H4 H9. change (inc (W u y) Bnat). app (sub_interval_Bnat H9).
  assert (sub (interval_Bnat card_zero c) (domain (graph y))). wr H6. rw H2.
  app interval_cc_0a_increasing. rwi interval_Bnat_pr0 H5. am. am.
  uf sum_to_increasing_fun.
  assert (forall u, inc u (domain (graph y)) -> is_cardinal (V u (graph y))).
  ir. cp (H8 _ H10). fprops. cp (sum_increasing1 H7 H10 H9). co_tac.
Qed.

Lemma sum_to_increasing2: forall n p,
  inc n Bnat -> inc p Bnat ->
  transf_axioms (fun y=> (sum_to_increasing_fct y n p))
  (set_of_functions_sum_le_int p n)
  (set_of_increasing_functions_int p n).
Proof. ir. red. ir. ufi set_of_functions_sum_le_int H1.
  cp (sum_to_increasing1 H H0 H1). rename c into y.
  ufi set_of_functions_sum_le H1. Ztac. clear H1. awi H3. ee.
  assert (source y = domain (graph y)). nin H1;ee;am.
  assert (fgraph (graph y)). fprops.
  assert (forall u, inc u (domain (graph y)) -> inc (V u (graph y)) Bnat).
  ir. assert (inc (W u y) (target y)). wri H6 H8. fprops.
  rwi H5 H9. change (inc (W u y) Bnat). app (sub_interval_Bnat H9).
  uf sum_to_increasing_fct. wr H3.
  set (g:= BL (sum_to_increasing_fun y) (source y) (interval_Bnat card_zero n)).
  assert (is_function g). uf g. app bl_function. ue.
  uf set_of_increasing_functions_int. Ztac. aw. eee. uf g. aw. uf g. aw.
  red. ee. am. nin (interval_Bnato_worder inc0_Bnat H0). am.
  nin (interval_Bnato_worder inc0_Bnat H). am. rww interval_Bnato_substrate.
  uf g. aw. sy; am. fprops. uf g. aw. rww interval_Bnato_substrate. fprops.
  red. ir. uf g. uf sum_to_increasing_fct. rwii interval_Bnato_related H10. ee.
  rww bl_W. rww bl_W. rwii interval_Bnat_pr0 H11.
  assert (order (interval_Bnato card_zero n)).
  nin (interval_Bnato_worder inc0_Bnat H). am.
  apply (increasing_prop1 (sum_to_increasing_fun y) H0 H13).
  rw interval_Bnato_substrate. ir. app H2.
  rww interval_Bnat_pr0. fprops. am.
  ir. assert (inc n0 Bnat). nin H14. app (le_int_in_Bnat H14).
  assert (inc (succ n0) Bnat). fprops.
  assert(cardinal_le (succ n0) p). srw. fprops. fprops.
  rw interval_Bnato_related. ee. app H2. rww interval_Bnat_pr0. nin H14. am.
  app H2. rww interval_Bnat_pr0. uf sum_to_increasing_fun.
  set (fa:= (restr (graph y) (interval_Bnat card_zero (succ n0)))).
  assert (fgraph fa). uf fa. fprops.
  assert (domain fa = (interval_Bnat card_zero (succ n0))).
  uf fa. rw restr_domain. wr H6. set (t:= interval_Bnat card_zero (succ n0)).
  rw intersection2comm. wrr intersection2_sub. uf t. rw H3.
  app interval_cc_0a_increasing. fprops.
  cp (interval_cc_0a_increasing H0 H17).
  assert (forall u, inc u (domain fa) -> is_cardinal (V u fa)). ir.
  assert (inc (V u (graph y)) Bnat). app H8. wr H6. rw H3. app H20. wrr H19.
  uf fa. rw restr_ev. fprops. fprops. wr H6. rw H3. app H20. wrr H19.
  assert (sub (interval_Bnat card_zero n0) (domain fa)). rw H19.
  app interval_cc_0a_increasing. app is_less_than_succ. fprops.
  cp (sum_increasing1 H18 H21 H22).
  assert (restr fa (interval_Bnat card_zero n0) =
    restr (graph y) (interval_Bnat card_zero n0)). uf fa.
  assert (fgraph (graph y)). fprops.
  app (double_restrc H24 H0 H14). wrr H6. wr H24.
  ap (sum_increasing1 H18 H21 H22). fprops. am. am. am. ue. ue. ue. ue. fprops.
Qed.

Lemma sum_to_increasing4: forall n p,
  inc n Bnat -> inc p Bnat ->
  injective (BL (fun y=> (sum_to_increasing_fct y n p))
  (set_of_functions_sum_le_int p n)
  (set_of_increasing_functions_int p n)).
Proof. ir. red. app bl_injective. app sum_to_increasing2. ir.
  ufi sum_to_increasing_fct H3.
  cp H1. cp H2. ufi set_of_functions_sum_le_int H1.
  ufi set_of_functions_sum_le_int H2.
  ufi set_of_functions_sum_le H1. ufi set_of_functions_sum_le H2.
  Ztac. clear H2. Ztac. clear H1. awi H6. awi H2. ee.
  app function_exten. ue. ue. rw H2. ir.
  assert(forall a, inc a (source u) -> is_cardinal (W a u)).
  ir. assert (inc (W a u) (target u)). fprops. rwi H9 H14.
  rwi interval_Bnat_pr0 H14. nin H14. am. am.
  assert(forall a, inc a (source v) -> is_cardinal (W a v)).
  ir. assert (inc (W a v) (target v)). fprops. rwi H11 H15.
  rwi interval_Bnat_pr0 H15. nin H15. am. am.
  cp (induction_on_sum3 H1 H0 H2 H13).
  cp (induction_on_sum3 H6 H0 H10 H14). ee.
  cp (f_equal (fun f=> W x f) H3). simpl in H19.
  cp (sum_to_increasing1 H H0 H4). cp (sum_to_increasing1 H H0 H5).
  rwii bl_W H19. rwii bl_W H19.
  ufi sum_to_increasing_fun H19.
  nin (equal_or_not x card_zero). rwi H22 H19. rwi H16 H19. rwi H15 H19.
  rww H22. rwi interval_Bnat_pr0 H12.
  cp (H18 _ H12). cp (H17 _ H12). wri interval_co_cc H23. rwi H19 H23.
  wri interval_co_cc H24. wri H24 H23. clear H24.
  assert (is_finite_c x). wr inc_Bnat. app (le_int_in_Bnat H12).
  cp (predc_pr H24 H22). nin H25. assert (Ha:=H12).
  set (q:= predc x). rwi H26 H12. srwi H12. nin H12.
  cp (f_equal (fun f=> W (predc x) f) H3). simpl in H28.
  wri interval_Bnat_pr0 H12.
  rwii bl_W H28. rwii bl_W H28. ufi sum_to_increasing_fun H28.
  rwi H26 H23. wri interval_co_cc H23. wri H28 H23.
  set (t1:= (cardinal_sum
    (restr (graph u) (interval_Bnat card_zero (predc x))))) in *.
  wri H26 H23. apply plus_simplifiable_left with t1.
  red in H20. ufi sum_to_increasing_fun H20.
  cp (H20 _ H12). fold t1 in H29. app (sub_interval_Bnat H29).
  assert (inc (W x u) (target u)). assert (inc x (source u)). rww H2.
  rww interval_Bnat_pr0. fprops. rwi H9 H29. app (sub_interval_Bnat H29).
  assert (inc (W x v) (target v)). assert (inc x (source v)). ue.
  rww interval_Bnat_pr0. fprops. rwi H11 H29. app (sub_interval_Bnat H29).
  am. bw. am. bw. fprops. fprops. Bnat_tac. Bnat_tac. fprops.
Qed.

Lemma sum_to_increasing5: forall n p,
  inc n Bnat -> inc p Bnat ->
  surjective (BL (fun y=> (sum_to_increasing_fct y n p))
  (set_of_functions_sum_le_int p n)
  (set_of_increasing_functions_int p n)).
Proof. ir. app bl_surjective. app sum_to_increasing2. ir.
  ufi set_of_increasing_functions_int H1. Ztac. clear H1.
  uf set_of_functions_sum_le_int. uf sum_to_increasing_fct.
  set (E1:= interval_Bnat card_zero p) in *.
  set (E2:= interval_Bnat card_zero n) in *. awi H2. ee.
  assert (Hb:inc card_zero E1). uf E1. rw interval_Bnat_pr0. fprops. am.
  set (a:= W card_zero y). assert (inc a E2). wr H4. uf a. app inc_W_target.
  rw H2. uf E1. rw interval_Bnat_pr0. fprops. am.
  assert (forall u, u<> card_zero -> inc u (source y) ->
    exists v, inc v (source y) & u = succ v & v = predc u
      & cardinal_le (W v y) (W u y)).
  ir. cp H7. rwi H2 H7. ufi E1 H7. rwi interval_Bnat_pr0 H7.
  assert (is_finite_c u). wr inc_Bnat. Bnat_tac.
  cp (predc_pr H9 H6). nin H10. exists (predc u).
  assert (inc (predc u) (source y)). rw H2; uf E1. rw interval_Bnat_pr0.
  rwi H11 H7. srwi H7. nin H7. am. bw. fprops. fprops. am. split.
  am. ee. am. tv. assert (gle (interval_Bnato card_zero p) (predc u) u).
  rw interval_Bnato_related. fold E1. wr H2. ee. am. am.
  assert (cardinal_lt (predc u) u). rw H11. srw. wr H11. fprops.
  nin H13; am. fprops. am. red in H3. ee. cp (H18 _ _ H13).
  rwi interval_Bnato_related H19. ee. am. fprops. am. am.
  set (f:= fun i => Yo(i= card_zero) a (card_sub (W i y) (W (predc i) y))).
  assert (forall i, inc i E1 -> inc (f i) E2). ir.
  nin (equal_or_not i card_zero). rw H8. uf f. rww Y_if_rw. uf f.
  rww Y_if_not_rw. wri H2 H7. cp (H6 _ H8 H7). nin H9. ee. wr H11.
  assert (sub (target y) Bnat). rw H4. uf E2. app sub_interval_Bnat.
  assert (inc (W i y) Bnat). app H13. fprops.
  assert (inc (W x y) Bnat). app H13. fprops.
  cp (card_sub_pr H14 H15 H12). rwi card_plus_commutative H16.
  assert (is_cardinal (card_sub (W i y) (W x y))). fprops.
  assert (is_cardinal (W x y)). fprops. cp (sum_increasing3 H17 H18).
  rwi H16 H19. uf E2. rw interval_Bnat_pr0.
  assert (cardinal_le (W i y) n). wr interval_Bnat_pr0. fold E2. wr H4. fprops.
  am. co_tac. am.
  set (g:=BL f E1 E2). assert (is_function g). uf g. app bl_function.
  assert (inc g (set_of_functions E1 E2)). aw. ee. am. uf g. aw. uf g. aw.
  assert (source g = interval_Bnat card_zero p). uf g. aw.
  assert (forall a, inc a (source g) -> is_cardinal (W a g)). ir.
  assert (inc (W a0 g) (target g)). fprops. ufi g H12. awi H12. ufi E2 H12.
  rwi interval_Bnat_pr0 H12. nin H12. uf g. aw. uf E1. wrr H10. am. am. uf E1.
  ue.
  nin (induction_on_sum3 H8 H0 H10 H11).
  set (h:= fun i=> cardinal_sum (restr (graph g) (interval_Bnat card_zero i))).
  assert(h card_zero = W card_zero y). uf h. rw H12.
  uf g. rw bl_W. uf f. rww Y_if_rw. am. am.
  assert (forall i, inc i E1 -> h i = W i y). ir. ufi E1 H15.
  rwi interval_Bnat_pr0 H15.
  app (cardinal_c_induction5_v (fun i=> h i = W i y) H0 H14). ir.
  uf h. set (n1:= succ n0). assert (cardinal_le n1 p). uf n1. srw.
  nin H16. nin H16; am. fprops. cp (H13 _ H18). ufi n1 H19.
  wri interval_co_cc H19. wri interval_co_cc H19. uf n1. wr H19. clear H19.
  ufi h H17. rw H17. uf g. rw bl_W. uf f.
  assert (succ n0 <> card_zero). fprops. cp (succ_positive n0). nin H19.
  intuition. rw Y_if_not_rw. assert (inc (succ n0) (source y)). rw H2.
  uf E1. rw interval_Bnat_pr0. fold n1. am. am.
  cp (H6 _ H19 H20). nin H21. ee.
  assert (n0 = x). app succ_injective. nin H16; nin H16. am. rwi H2 H21.
  ufi E1 H21. rwi interval_Bnat_pr0 H21. nin H21. am. am. wr H23.
  rw H25. rwi H25 H24. rww card_sub_pr.
  assert (inc (W (succ x) y) (target y)). app inc_W_target. wrr H25.
  rwi H4 H26. ufi E2 H26. app (sub_interval_Bnat H26).
  assert (inc (W x y) (target y)). app inc_W_target. wrr H25.
  rwi H4 H26. ufi E2 H26. rw H25. app (sub_interval_Bnat H26). am. tv.
  uf E1. rw interval_Bnat_pr0. am. am. fold n1. app (le_int_in_Bnat H18).
  nin H16. Bnat_tac. am.
  assert (inc g (set_of_functions_sum_le E1 n)).
  uf set_of_functions_sum_le. Ztac.
  assert (inc p E1). uf E1. rww interval_Bnat_pr0. fprops. cp (H15 _ H16).
  ufi h H17. assert (restr (graph g) (interval_Bnat card_zero p) = graph g).
  assert (domain (graph g) = (interval_Bnat card_zero p)).
  red in H8. ee. wr H19. uf g. aw. wr H18. assert (fgraph (graph g)). fprops.
  app restr_to_domain. fprops. rwi H18 H17. ufi graph H17. rw H17.
  wr interval_Bnat_pr0. fold E2. wr H4. wri H2 H16. fprops. am. ex_tac.
  cp (sum_to_increasing1 H H0 H16). sy. app function_exten.
  app bl_function. aw. aw. ir. rww bl_W.
  uf sum_to_increasing_fun. wrr H15. ue. ue.
Qed.

Lemma sum_to_increasing6: forall n p,
  cardinal (set_of_functions_sum_le_int (nat_to_B p) (nat_to_B n)) =
  nat_to_B(binom (n+p+1) (p+1)).
Proof. ir. wr card_set_of_increasing_functions_int. aw.
  set (nn:= nat_to_B n). set (pp:= nat_to_B p).
  assert (inc nn Bnat). uf nn. fprops. assert (inc pp Bnat). uf pp. fprops.
  exists (BL (fun y=> (sum_to_increasing_fct y nn pp))
    (set_of_functions_sum_le_int pp nn)
    (set_of_increasing_functions_int pp nn)).
  split. split. app sum_to_increasing4. app sum_to_increasing5. aw. au.
Qed.

End IntegerProps.
Export IntegerProps.