Math 455.1  •  10 February 2009

Combinatorics

Version 7.02

Adapted in part from a notebook by Ernest G. Manes

Initializations

The Mathematica functions introduced in this notebook are a mixture of built-in functions, functions from the Combinatorica package, and functions defined in the Definitions section at the end of this notebook.  Relevant Mathematica definitions from SetsAndFunctions.nb are defined again in this notebook.

Like the cell below that loads the  Combinatorica package, the cells in the Definitions and Glossary sections at the end are initialization cells.

Needs["Combinatorica`"]

Basic counting formulas

Number of functions

The number of functions from an r-element set to an n-element set is (n^r). For example, the number of functions from a 100-element set to a 3-element set is:

(3^100)

Number of permutations

The number of injective (that is, one-to-one) functions from an r-element set to an n-element set—the number of permutations (or arrangements) of n things taken r at a time—is defined in this notebook as P[n,r]. For example:

Table[P[10,k],{k,0,10}]

Number of subsets of a specified size

For the number of r-element (unordered) subsets of an n-element set, however, we'll stick with Mathematica's buiilt-in Binomial[n,r]. For example:

Table[Binomial[10,k],{k,0,10}]

This suggests the following expression for Pascal's Triangle:

PascalTriangle[m_Integer?NonNegative]:=Table[Binomial[n,k],{n,0,m}, {k,0,n}]

PascalTriangle[7]//TableForm

Observe here that each entry in a particular row is the sum of two numbers: the entry directly above it and the entry directly above and to its left. (You have to imagine a column of 0's to the left of the leftmost column and a diagonal of 0's on top of the top-right diagonal of 1's.) The same is true no matter what the value m of the argument of PascalTriangle. This suggests a new, recursive definition of the binomial coefficients that makes use of the addition formula.

recBinomial[n_Integer?NonNegative,0]=1;
recBinomial[n_Integer?NonNegative,n_]=1;
recBinomial[n_Integer,k_Integer]:= recBinomial[n-1,k-1]+recBinomial[n-1,k]/;0<k&&k<n

How does this recursive definition compare in efficiency with the built-in definition for Binomial?  Time them as follows. (The ClearSystemCache[] call is to make sure that no previously stored results are being summoned by Mathematica so as to shortcut the evaluations.)

m=20;
ClearSystemCache[];
Timing[Table[Binomial[m,k],{k,0,m}]]
ClearSystemCache[];
Timing[Table[recBinomial[m,k],{k,0,m}]]

You should have observed that the recursive form takes longer. Why might this be so?

Evaluate the following cells to illustrate the fact that p divides Binomial[p,k] when p is prime with 0 < k < p but need not do so when p is not prime.

Table[(1/11) Binomial[11,k],{k,1,10}]

Table[(1/12) Binomial[12,k],{k,1,10}]

Sets and subsets

Recall that, in Mathematica, a set is just a list with no repetitions. The order doesn't matter either but there is no way to actually list the elements of a set without choosing some order. (For more about this, see notebook SetsAndFunctions.nb from the Math 455.1 web site Files page.)

The Combinatorica function Subsets returns the set of all subsets of its argument. For example:

Clear[a,b,c]
Subsets[{a,b,c}]

The Combinatorica function KSubsets returns just those subsets of a specified size: KSubsets[x,k] returns the set of all k-element subsets of the set x. For example:

KSubsets[{a,b,c,d},3]

When the set whose subsets you want gets a bit long, the result printed by Mathematica may not look so nice. For example:

Clear[a,b,c,d,e,f,g,h]
KSubsets[{a,b,c,d,e,f,g,h},3]

In such cases you may want to use the produce a more nicely formatted output; to do so, use the TablePrinter utility function defined in this notebook. For example:

TablePrinter[KSubsets[{a,b,c,d,e,f,g,h},3]]

Functions

Functions in general

As in notebook SetsAndFunctions.nb, represent a function as a three-entry list
	f = { {(Subscript[x, 1]), …, (Subscript[x, m])}, {(Subscript[y, 1]), …, (Subscript[y, n])}, {(Subscript[z, 1]), …, (Subscript[z, m])} } 
where the function's domain is {(Subscript[x, 1]), …, (Subscript[x, m])}, its codomain is  {(Subscript[y, 1]), …, (Subscript[y, n])}, and for each element (Subscript[x, i]) of the domain, the value of the function at that element is f((Subscript[x, i])) = (Subscript[z, i]).

To test whether a list represents a function, use FunctionQ.  For example:

Clear[a,b,c,α,β]
f1={{a,b},{1,2,3,4},{2,4}};
f2={Range[5],{α,β},{β,α,α,α,β} };
f3={{a},{b},{c}};
{FunctionQ[f1],FunctionQ[f2],FunctionQ[f3]}

The object f3 is not a function because the value c of f at the element a of the domain is not in the codomain {b}.

Our Mathematica representation of a function is a list of three things—the domain, the codomain, and the list that gives the "rule" for the function.  If you know how the elements of the domain are ordered, then you can reconstruct the function's rule. If you want to see just the list that gives the rule, extract it from the function as shown below:

f1                      (* the function *)
Last[f1]       (* its "rule" *)

The expression Functions[d,c] lists all functions from the domain set d to the codomain set c.  The output is a set of functions with common domain and codomain.  The set of all these functions is shown as a list of form {d , c , { (Subscript[f, 1]), …, (Subscript[f, k])}} where each {d, c, (Subscript[f, i])} represents a function.  For example:

Functions[{a,b},{1,2,3}]

To extract from a Functions expression just the "rules" for all the functions, use Last:

Last[Functions[{a,b},{1,2,3}]]

The nested brackets in such expressions can be awkward to type and to read, so it is often convenient to use Last in the prefix form shown below:

Last @ Functions[{a,b},{1,2,3}]

You may use a prefix form not just for Last, but for any one-argument function.

You can test for such a set of functions with the expression SetOfFunctionsQ.  For example:

testset=Functions[{a,b},{1,2,3}];
SetOfFunctionsQ[testset]

To list a set of functions neatly, yo may use the utility function FunctionsPrinter defined in this notebook. The syntax is FunctionsPrinter[caption,fcn]. The caption is a string that is printed at the beginning of the table. For no caption use the empty string "" . Try this:

testset=Functions[{a,b,c},{1,2,3}]
FunctionsPrinter["All functions from {a,b} to {1,2,3}.",testset]

Injections

The Mathematica function InjectiveQ defined in this notebook tests whether a function is injective (that is, one-to-one). Try these:

const={{1,2,3},{a,b,c},{b,b,b}};
inj={{1,2,3},{a,b,c},{b,c,a} };
{InjectiveQ[const],InjectiveQ[inj]}

Use FunctionSelect to select from a set of functions those functions that satisfy a specified condition. The condition must be a Mathematica function that takes functions in our sense as argument; that is, the condition must accept inputs of the form {domain, codomain, rule}. Of course InjectiveQ is an example of just such a condition. For example:

FunctionSelect[Functions[{a,b},{1,2,3,4}],InjectiveQ]

FunctionsPrinter["some injective functions", 
	FunctionSelect[Functions[{a,b},{1,2,3,4}],InjectiveQ]]

How many functions from {a,b,c} to {1,2,3,4} are injective or map into {1,2,3}?
You can figure such things analytically, without any experimentation. There are P(4, 3) = 4 · 3 · 2 = 24 injective functions. And (3^3) = 27 functions map into {1,2,3}. But 3! = 6 of these 27 functions are injective and so have been counted twice. So the number we want is 24 + (27 - 6) = 45 functions in all.
You can confirm that result experimentally by creating the list of functions in question and counting how many there are. First define the test for mapping into {1,2,3}:

in123Q[f_?FunctionQ]:=SubsetQ[Union[f[[3]]],{1,2,3}]

Noting that || means "or", we then have:

Card[Last @ FunctionSelect[Functions[{a,b,c},Range[4]],InjectiveQ]]

Card[Last @ FunctionSelect[Functions[{a,b,c},Range[4]],in123Q]]

Card[Last @ FunctionSelect[Functions[{a,b,c},Range[4]],InjectiveQ[#1] || in123Q[#1]&]]

Surjections

The Mathematica function SurjectiveQ defined in this notebook tests whether a function is surjective (that is, takes as values all the members of its codomain). Using FunctionSelect you can therefore list all surjective functions from one set to another.

FunctionSelect[Functions[{a,b,c},{1,2}],SurjectiveQ]

Notice the option numberColumns option to FunctionsPrinter below to specify the number of columns.

FunctionsPrinter["surjective ones only",FunctionSelect[Functions[{a,b,c},{1,2}],SurjectiveQ], numberColumns -> 3]

This notebook defines the function Onto for counting the number of surjective (that is, "onto") functions. For example:

TableForm[Table[Onto[n,r],{n,0,4},{r,0,4}], TableHeadings->{{"n=0","n=1","n=2","n=3","n=4"},{"r=0","r=1","r=2","r=3","r=4"}}]

Bijections

The Mathematica function BijectiveQ defined in this notebook allows you to select functions that are bijective (that is, both injective and surjective—in other words, one-to-one correspondences between their domains and codomains).  For example, there are 3! = 6 bijective functions from a three element set {a,b,c} to itself. Find them with the following expression:

FunctionSelect[Functions[{a,b,c},{a,b,c}], BijectiveQ]

Bijections as permutations

An alternate way of representing a bijection f: X -> X from a set Xto itself is as an ordered list ((Subscript[y, 1]),(Subscript[y, 2]), …, (Subscript[y, n])) whose jth entry is, for each j, the value of f at the jth element of X.  Remember, such an ordered list in the mathematical sense is represented by a Mathematica list {(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[…y, n])}. (The items in a Mathematica list are ordered by their positions in the list!) For example, the bijection
	{ {a, b, c}, {a, b, c}, {c, b, a} }
could be represented more simply as:
	{c, b, a}

Mathematica's built-in function Permutations gives all the permutations of a set in this alternate representation. For example:

Permutations[{a,b,c}]

Thus, an alternate expression for the set of all bijective functions from {a,b,c} to itself is

{{a,b,c},{a,b,c},Permutations[{a,b,c}] }

When the set X in question is {1, 2, …, n} for some positive integer n, then the Combinatorica function PermutationQ tells whether a given list is a permutation of X. For example:

PermutationQ[{1,3,2}]

Unfortunately, PermutatationQ does not work as you might wish when the set in question is something more general. For example, the expression PermutationQ[{a,c,b}] has value False.

Derangements (advanced topic)

A derangement is an injective function f from a set to itself which has no "fixed points", that is, for which f(x) ≠ x for all x ∈ X.  If you order the members of the domain X of f somehow, and if you then regard an injective function f: X -> X as specifying an arrangement of the members of X, then a derangement of X may be regarded as an arrangement of the members of X in which no entry appears in its correct order.

This notebook defines a function DerangementFunctionQ to test whether a function is a derangement. For example:

DerangementFunctionQ[{{a,b,c,d},{a,b,c,d},{d,a,b,c}}]
DerangementFunctionQ[{{a,b,c,d},{a,b,c,d},{d,b,a,c}}]

You can use FunctionSelect twith test condition DerangementFunctionQ to list all derangements of a set. For example:.

FunctionSelect[Functions[{a,b,c,d},{a,b,c,d}],DerangementFunctionQ]

And of course you can use FunctionsPrinter to format that nicely:

FunctionsPrinter["All derangements.", FunctionSelect[Functions[{a,b,c,d},{a,b,c,d}],DerangementFunctionQ]]

A derangement is a special kind of bijection. Recall that you may represent any bijection more simply as a permutation—as an ordered list in "scrambled order"; see Bijections as permutations, above. Then in particular you can represent derangements in this simpler way. Several Combinatorica functions deal with derangments this way—but only for derangements of sets of the form {1, 2, …, n}, that is, Range[n] for a positive integer n.  These functions are DerangementQ, Derangements, and NumberOfDerangements.  For example:

{DerangementQ[{4,1,2,3}],DerangementQ[{4,2,1,3}]}

Derangements[4]

Card[Derangements[4]]

You may find the number of derangements without acutally forming the set of derangements:

NumberOfDerangements[4]

Table[NumberOfDerangements[n],{n,1,10}]

The number of derangements of {1, 2, …, n} indeed grows rapidly with n.  For example:

NumberOfDerangements[100]

The ratio NumberOfDerangements[n]/n! represents the fraction of all permutations of {1, 2, …, n} that are derangements; in other words, this ratio represents the "probability" that a randomly chosen permutation of {1, 2, …, n} is a derangement. This ratio has an interesting approximation for "large" values of n. Look first at the following, when n=100:

Table[{n,N[(1/E) - ((NumberOfDerangements[n])/(n!))]},{n,10,20}]//TableForm

The last of the differences in that tablecannot possibly be exactly 0: after all, the ratio NumberOfDerangements[n]/n! is a rational number, whereas 1/E is irrational. The misleading result of 0. owes to rounding; to get a more precise result, calculate to a higher precision and allow Mathematica to use even more decimal digits than it normally does, like this:

Block[{$MaxExtraPrecision=500},Table[{n,N[(1/E) - ((NumberOfDerangements[n])/(n!)),15]},{n,10,20}]//TableForm]

The size of the difference between the ratio  NumberOfDerangements[n]/n! and 1/E is clearly geting smaller.

Partitions of a set; Bell and Stirling numbers (advanced topic)

The Combinatorica function SetPartitions returns a list of all the partitions of a set into nonempty, pairwise-disjoint subsets. And the Combinatorica function KSetPartitions returns the list of just those partitions that have a specified number of subsets. For example:

SetPartitions[{a,b,c}]

KSetPartitions[Range[5],3]

⚠  Caution:  These Combinatorica nctions SetPartitions and KSetPartitions do not check whether the (first) argument is, in fact a set.

Number of partitions into r-element subsets: Stirling numbers of the second kind

The Stirling number {({{n}, {r}})} of the second kind is the number of partitions of an n-element set into r subsets—not the number of partitions into r-element subsets! The Combinatorica function StirlingSecond implements this function (as does the built-in Mathematica function StirlingS2.)

SetPartitions[{a,b,c,d}]
Card/@SetPartitions[{a,b,c,d}]
StirlingSeconed[Card[{a,b,c,d}],3]

Number of partitions: Bell numbers

Recall the earlier example:

SetPartitions[{a,b,c}]

Card[SetPartitions[{a,b,c}]]

The n-th Bell number (Subscript[B, n]) is the number of partitions of an n-element set. So (Subscript[B, 3]) = 5. In general, to calculate (Subscript[B, n]) you could form all the partitions of an n-element set with the Combinatorica function SetPartitions and then count how many there are. Here's a function to do that:

BellNumber[n_Integer?NonNegative]:=Card[SetPartitions[Range[n]]]

This direct definition turns out to be relatively slow (you'll see just how slow if you increase 10 below to 20 or even just to 12):

Timing[Table[BellNumber[n],{n,0,10}]]

The Combinatorica function BellB uses the recursive formula:
		(Subscript[B, n]) =(∑_( k = 0)^( n - 1)) (({{n - 1}, {k}}))  (Subscript[B, k])
This recursive formula is much faster than directly forming and counting partitions:

Timing[Table[BellB[n],{n,0,20}]]

A third way to calculate the Bell numbers is by Dobinski's formula, which uses an infinite series:

Dobinski[n_Integer?NonNegative]:=(1/E)(∑_(k=1)^∞)((k^n)/(k!))

Timing[Table[Dobinski[n],{n,1,5}]]

You won't want to evaluate the function Dobinski for very large n. However, the following formula, which uses only a partial sum of the infinite series, provides a decent approximation and is not too slow:

ApproximateDobinski[n_Integer?NonNegative]:=Ceiling[N[(1/E)(∑_(k = 1)^30)((k^n)/(k!)) - 0.1]]

Timing[Table[ApproximateDobinski[n],{n,1,20}]]

Glossary

Names of Mathematica combinatorics functions that are defined in this notebook are listed in the next cell.

Off[General::spell1]
Clear[BijectiveQ,Card,DerangementFunctionQ,DomainQ,FiniteQ,FunctionCompose,FunctionQ,Functions,FunctionSelect,InjectiveQ,Onto,P,PowerSet, S,SetProduct,SetQ,SetsEqualQ,SubsetQ,SetOfFunctionsQ,SurjectiveQ];
On[General::spell1]

Usage messages for those functions are defined in the next several cells.  Reading these usage messages tells you the syntax of the corresponding functions, defined later, and what these functions do.

First, usage messages for functions about sets.

Card::usage="Card[x] gives the cardinality of x -- the number of elements in x -- if x is a finite set.";

DomainQ::usage="DomainQ[s] is True if s is among a specific list of domains (ℙ,ℕ,ℤ,ℚ,ℝ,ℂ,𝔸,𝔹), False otherwise.";

FiniteQ::usage="FiniteQ[s] is True if s is a finite set, False otherwise.";

PowerSet::usage="PowerSet[s] (where setQ[s] is True) gives the list of all subsets of s." ;

SetProduct::usage= "SetProduct[x1, ..., xn], where n > 0, gives the cartesian product of all n sets as a list of n-tuples.";

SetQ::usage"SetQ[x] gives True if x is a set, and False otherwise; {a,b,a} is not a set because a repetition occurs." ;

SetsEqualQ::usage="SetsEqualQ[x,y] gives True if x, y are equal sets, and False otherwise.";

SubsetQ::usage = "SubsetQ[ x , y ] gives True if x , y are sets and x is a subset of y, and False otherwise." ;

Next, usage messages for functions about functions.

DerangementFunctionQ::usage="DerangmentFunctionQ[f] gives True if f is a function that is a derangement of its domain.";

FunctionCompose::usage= 
"FunctionCompose[g, f] gives the composition of the function g following the function f; the domain of g must equal the codomain of f.";

FunctionQ::usage=
"FunctionQ[f] gives True if f is a function in the form {domain, codomain, values}, and False otherwise.";

Functions::usage="Functions[dom,codom] gives the set of all functions from the set dom to the set codom.";

BijectiveQ::usage="BijectiveQ[f] gives True if f is a bijective function, and False otherwise.";

InjectiveQ::usage="InjectiveQ[f] gives True if f is an injective function, and False otherwise.";

SetOfFunctionsQ::usage="SetOfFunctions[set] gives True if set is a set of functions, and False otherwise.";

SurjectiveQ::usage="SurjectiveQ[f] gives True if f is a surjective function, and False otherwise.";

Finally, usage messages for functions giving basic combinatoric formulas.

Onto::usage"Onto[n, r] give the number of surjective functions from an n-element set to an r-element set.";

P::usage="P[n, r] gives the number of permutations of n distinct objects taken r at a time.";

S::usage="S[n, r] is an alias for the Stirling number of the second kind StirlingSecond[n, r].";

Definitions

Utilities

ds::improper = "The expression `1` has been improperly specified.  For " <> 
"proper syntax type ?`2`.";

Clear[typeCheck]
Attributes[typeCheck]={HoldAll};
typeCheck[test_ ,expr_, call_String,stem_String]:=
		If[ test,
	expr,
		Message[ds::improper, call ,
			  stem ]]

Remove[TablePrinter]
TablePrinter::"usage"="TablePrinter[ls] prints out the elements of the list ls as a two-dimensional table. There are a great many options to format the result.  Options for the table include numberColumns (the number of columns), spaceBetween (the number of spaces between columns), lineSize (the number of characters in a row), TableAlignments (Left, Right or Center for alignment within each column) and TableHeadings (how to label each row and each column just as for TableForm--see Mathematica help).  If you omit all options, there were be no row or column headings and the system will try to automatically determine good values for the other options.  Additionally you can specify a table caption both before and/or after the table.  For the caption before use precaption->string; the options preFontSize, preFontColor, preBackground, preFontFamily, preFontWeight, preFontSlant, preCellLabel can be set to specify the caption font size, font color, background color, font family (e.g. Times, Ariel, etc.), FontWeight (Plain or Bold), FontSlant (Plain or Italic), Cell Label (set to an empty string if you don't want one) and TextAlignment (Left, Center or Right).  The caption following the table is similar using postCaption, postFontSize, postFontCol, postBackGround, postFontFamily, postFontWeight, postFontSlant, postCellLabel and postTextAlignment.";
Options[TablePrinter]={numberColumns->Automatic,spaceBetween->1,lineSize->50,preCaption->"",preFontSize->12.`,preFontColor->GrayLevel[0.`],preBackground->None,preFontFamily->Times,preFontWeight->Plain,preFontSlant->Plain,preCellLabel->None,preTextAlignment->Left,postCaption->"",postFontSize->12.`,postFontColor->GrayLevel[0.`],postBackground->None,postFontFamily->Times,postFontWeight->Plain,postFontSlant->Plain,postCellLabel->None,postTextAlignment->Left};
Off[General::"spell",General::"spell1"];
TablePrinter[lst_,opts___]:=typeCheck[ListQ[lst],Module[{cols,sb,lsz,precap,postcap,theList,mx,optTableForm},optTableForm=Sequence@@FilterRules[Flatten[{opts}],Options[TableForm]];cols=numberColumns/.{opts}/.Options[TablePrinter];sb=spaceBetween/.{opts}/.Options[TablePrinter];lsz=lineSize/.{opts}/.Options[TablePrinter];precap=preCaption/.{opts}/.Options[TablePrinter];postcap=postCaption/.{opts}/.Options[TablePrinter];theList=ToString/@lst;mx=Max@@StringLength/@theList;If[cols==Automatic,cols=Floor[(lsz/(sb+mx))]];cols=Max[1,Min[cols,80]];theList=Join[theList,Table["",{Mod[Length[theList],cols]}]];If[StringLength[precap]>0,Module[{prfs,prfc,prbg,prff,prfw,prssl,prscl,prsta},prfs=preFontSize/.{opts}/.Options[TablePrinter];prfc=preFontColor/.{opts}/.Options[TablePrinter];prbg=preBackground/.{opts}/.Options[TablePrinter];prff=preFontFamily/.{opts}/.Options[TablePrinter];prfw=preFontWeight/.{opts}/.Options[TablePrinter];prssl=preFontSlant/.{opts}/.Options[TablePrinter];prscl=preCellLabel/.{opts}/.Options[TablePrinter] (prsta=preTextAlignment/.{opts}/.Options[TablePrinter]);Print[Style[precap,"Output",FontSize->prfs,FontColor->prfc,Background->prbg,FontFamily->prff,FontWeight->prfw,FontSlant->prssl,CellLabel->prscl,TextAlignment->prsta]]]];Print[Style[Partition[theList,cols],"Output"]];If[StringLength[postcap]>0,Module[{posfs,posfc,posbg,posff,posfw,possl,poscl,posta},posfs=postFontSize/.{opts}/.Options[TablePrinter];posfc=postFontColor/.{opts}/.Options[TablePrinter];posbg=postBackground/.{opts}/.Options[TablePrinter];posff=postFontFamily/.{opts}/.Options[TablePrinter];posfw=postFontWeight/.{opts}/.Options[TablePrinter];possl=postFontSlant/.{opts}/.Options[TablePrinter];poscl=postCellLabel/.{opts}/.Options[TablePrinter];posta=postTextAlignment/.{opts}/.Options[TablePrinter];Print[Style[postcap,"Output",FontSize->posfs,FontColor->posfc,Background->posbg,FontFamily->posff,FontWeight->posfw,FontSlant->possl,CellLabel->poscl,TextAlignment->posta]]]]],"TablePrinter[ls]","TablePrinter"];
On[General::"spell",General::"spell1"];

Remove[listOfListsPrinter]
Options[listOfListsPrinter]={numberColumns->Automatic};
listOfListsPrinter[lsofls_List,opts___]:=Module[{tbl=lsofls,spaceBetween=3,lineSize=50,spaces,cols,entsize,getline,ret="",ln},spaces=StringTake["          ",spaceBetween];cols=numberColumns/.{opts}/.Options[listOfListsPrinter];If[cols==Automatic,entsize=Max@@(StringLength[ToString[#1]]&)/@tbl;cols=Max[1,Min[Floor[(lineSize/(spaceBetween+entsize))],10]];];tbl=Join[tbl,Table["",{cols-Mod[Length[tbl],cols]}]];StringJoin[Table[StringJoin[(ToString[#1]<>"   "&)/@Partition[tbl,cols][[i]]]<>"\n",{i,((Length[tbl])/cols)}]]]

Remove[FunctionsPrinter]
Options[FunctionsPrinter]=Options[listOfListsPrinter];
FunctionsPrinter[caption_String,{domain_,codomain_,fcns_}?SetOfFunctionsQ,opts___]:=Module[{cols,ret},ret=caption<>"\n \n";ret=ret<>"Domain:   "<>ToString[domain]<>"\n";ret=ret<>"Codomain: "<>ToString[codomain]<>"\n \n";cols=numberColumns/.{opts}/.Options[FunctionsPrinter];ret<>listOfListsPrinter[fcns,numberColumns->cols]]

Sets

∅={};
ℝ=Reals;ℤ=Integers;ℂ=Complexes;𝔸=Algebraics;ℙ=Primes;ℚ=Rationals;𝔹=Booleans;ℕ=Naturals;

Card[x_?SetQ]:=Count[x,_]

DomainQ[dom_]:=MemberQ[{ℝ,ℤ,ℂ,𝔸,ℙ,ℚ,𝔹,ℕ},dom]

FiniteQ[x_]:=SetQ[x]&&!DomainQ[x]

PowerSet[set_?SetQ]:=Subsets[set] 

SetProduct[x__?SetQ]:=If[ Length[{x}]==1,Flatten[{x}],
	 Flatten[ Outer[ List,x],Length[{x}]-1 ]]

SetsEqualQ[x_,y_]:=SetQ[x]&&SetQ[y]&&(Union[x]===Union[y])

SetQ[x_]:=ListQ[x]&&(Length[x]==Length[Union[x]])

SubsetQ[x_,y_]:=SetQ[x]&&SetQ[y]&&And@@(MemberQ[y,#]&)/@x

Unprotect[Element];
Element[x_,Naturals]:=Element[x,Integers]&&NonNegative[x]
Element[x_,lis_?FiniteQ]:=MemberQ[lis,x]
Protect[Element];

Unprotect[Subset]
Subset[x_,y_]:=SubsetQ[x,y]
Protect[Subset]

Functions

BijectiveQ[f_?FunctionQ]:=InjectiveQ[f]&&SurjectiveQ[f]

DerangementFunctionQ[d_]:=InjectiveQ[d]&&Union[d[[1]]]==Union[d[[2]]]&&!(MemberQ[(Equal@@#&)/@Thread[{d[[3]],d[[1]]}],True])

FunctionCompose[ g_,f_ ]:= typeCheck[FunctionQ[f]&&FunctionQ[g]&&(Union[f[[2]]] ===Union[g[[1]]]), "FunctionCompose[f,g]","FunctionCompose", {f[[1]],g[[2]],Table[ g[[3,Position[g[[1]],f[[3,i]]][[1,1]]]] ,{i,Length[f[[1]]]}]}
	]

FunctionQ[{d_,c_,f_}]:=SetQ[d]&&SetQ[c]&&Head[f]===List&&Length[d]==Length[f]&&SubsetQ[Union[f],c]

Functions[{ },c_?SetQ]={{ },c, {{ }}} ;
Functions[{e_},c_?SetQ]:={{e},c,Partition[c,1]}
Functions[d_?SetQ,c_?SetQ]:=Module[{fcns},fcns=Functions[Drop[d,-1],c][[3]]; {d,c,Join@@Table[(Join[{c[[i]]},#]&)/@fcns,{i,Length[c]}]}]

FunctionSelect[{dom_,cod_,fcns_}?SetOfFunctionsQ,constraint_]:={dom,cod,Select[fcns,constraint[{dom,cod,#}]&]}

InjectiveQ[fcn_]:=FunctionQ[fcn]&&SetQ[fcn[[3]]]

SetOfFunctionsQ[s_]:=Head[s]===List&&Length[s]==3&&Head[s[[3]]]===List&&And@@(FunctionQ[{s[[1]],s[[2]],#}]&)/@s[[3]]

SurjectiveQ[f_]:=FunctionQ[f]&&Length[f[[2]]]==Length[Union[f[[3]]]]

Basic combinatorial formulas

Onto[n_Integer?NonNegative,r_Integer?NonNegative]:=If[r>n,0,r! S[n,r]]

P[n_Integer?NonNegative,r_Integer?NonNegative]:=If[r>n,0,(( n!)/((n-r)!))]
S[n_Integer?NonNegative,r_Integer?NonNegative]:=Combinatorica`StirlingSecond[n,r]/;r≤n

Portions of notebook Copyright © 2009 by Murray Eisenberg. All rights reserved.