Mathematica Pearls:
Problems and Solutions

A reader submits three variations of a solution to the dinner guest problem.

Edited by Don T. Piele

In Volume 5, No. 2 of this journal, I posed the following problem (Menage II). At a dinner for 6 couples, the host assigns at random 4 people to sit at each of the 3 tables, with the restriction that each table should have two men and two women.This is done by allowing the women to be seated first, two to a table, and randomly placing the men in the empty seats. Find the probability that none of the married couples is sitting at the same table. (Blom 1991).

One way to model this problem is to number the tables from 1 to 3, and if a women is placed at table i then write out a slip for her husband with her table number on it. Thus the men will all end up with slips numbered { 1, 1, 2, 2, 3, 3}. If a husband with slip 1 sits at table 1 he will be sitting with his wife. Any complete permutation of the slip numbers will result in a seating where no husband sits with his own wife. A complete permutation (sometimes called a derangement) is any permutation where all positions are changed. For example {2,2,3,3,1,1}
is a complete permutation of {1,1,2,2,3,3,}.

Consider the general Menage II problem where 3 table (six couples) are replaced by n tables.

FURTHER GENERALIZATION

a) Generate the complete permutations of {1,1,2,2,3,3,....,n,n} for as large an n 
    as possible.
    
b) Is there a  way of counting the complete permutations of {1,1,2,2,3,3,...n,n}
    without generating them?
     
c) The number of different ways of seating the men is (2n)!/ (2 ^n). Thus the probability that none end up sitting with his own wife is: 

            number of  complete permutations  of {1,1,2,2,3,3,4,4,....n,n}
p[n] =    -------------------
                                  (2n)!/ (2 ^n)   
         
         Evaluate p[n]  for a few values of n.                         

 d) Does the Limit[p[n], n-> Infinity] exist?

Solution

By Robert M. Dickau (robertd@wolfram.com)

First Approach

First, a function that generates the list to permute, {1, 1, 2, 2, ..., n, n}.

cpStart[n_] := Flatten[Table[i, {i, n}, {2}]]

Next, a predicate that detects if one list is a derangement of another by seeing if the difference of the lists contains any zeros.

completePermutationQ[L1_, L2_] := FreeQ[L1 - L2, 0]

Somewhat inefficiently, this generates all the permutations of the cpStart list, and selects all those that are derangements of the cpStart list.

completePermutations[n_] := 
      Module[{st = cpStart[n]}, 
        Select[Permutations[st], completePermutationQ[#, st]&]]

Now, the first couple sets of complete permutations.

completePermutations[2]

completePermutations[3]

The function 𝓉𝒶𝒷ℓℯ𝓈 creates white disks representing the different tables at the dinner party, with dots at 6 and 9 o’clock representing the seated women, colored according to the table each woman is sitting at.

𝓉𝒶𝒷ℓℯ𝓈[n_] := 
      Table[{GrayLevel[1], Disk[{i - 1, 0}, 0.45], Hue[i/n], 
          Point[{i - 1 - 0.33, 0}], Point[{i - 1, -0.33}]}, {i, n}];

The function 𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂 creates dots at the 12 and 3 o’clock positions at the appropriate tables, where each dot represents a seated man, and where each dot is colored according to where the man’s wife is sitting.

𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂[L_List] := 
      Module[{lenL = Length[L], howfar}, 
        MapIndexed[
          (howfar =  Mod[#2[[1]] - 1, 2]; {Hue[2  #/lenL], 
                Point[{Floor[(#2[[1]] - 1)/2] + 
                      0.33  Cos[Pi/2 howfar], 0.33  Sin[Pi/2 howfar]}]})
              &, L]];

Finally, 𝓈𝒽ℴ𝓌𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂 fixes the plot styles and puts everything together into an array.

𝓈𝒽ℴ𝓌𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂[n_]:=Show[GraphicsArray[
            Partition[
              Graphics[{PointSize[0.04], 
                      𝓉𝒶𝒷ℓℯ𝓈[n], 
                      𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂[#]}, Frame -> True, 
                    FrameTicks -> False, Background -> GrayLevel[0.5], 
                    PlotRange -> All, AspectRatio -> Automatic]&/@
                completePermutations[n], n - 1]]];

Here are the first few diagrams.

𝓈𝒽ℴ𝓌𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂[2];

𝓈𝒽ℴ𝓌𝒸𝓅𝒟𝒾𝒶ℊ𝓇𝒶𝓂[3];

Second approach...(better)

One way to count the number of arrangements without (completely) enumerating them is to use generating functions. Suppose the dinner party has three tables, A, B, and C. The first empty seat at the first table can be filled by a person whose mate is at table B or C, which we represent by the factor (b + c); the second empty seat at table A has the same restriction, so we repeat the term. Each empty seat at table B can be filled by a person whose mate is at table A or C, and so we represent each seat at table B by a factor (a + c). After continuing for table C and multiplying the factors, we get the following expression.

Expand[(((b + c))^2) (((a + c))^2) (((a + b))^2)]

The coefficient of (a^2) (b^2) (c^2) in the result is the number of ways to seat six people so that no person is sitting at the same table as his or her mate.

Coefficient[(((b + c))^2) (((a + c))^2) (((a + b))^2), 
      (a^2) (b^2) (c^2)]

In this case, there are ten such arrangements.

The following function creates the generating function 𝓅 corresponding to the case of n couples, and extracts the coefficient of the appropriate term.

MenageII[n_Integer?Positive] := 
      Module[{L = Array[𝒶, {n}], ℒ, 𝓅}, 
        ℒ = Table[Drop[L, {i}], {i, n}]; 
        𝓅 = Times@@(((Plus@@#&/@ℒ))^2); 
        Coefficient[Expand[𝓅], Times@@L, 2]]

Three couples, ten permutations:

L = Array[𝒶, {3}]ℒ = Table[Drop[L, {i}], {i, 3}]𝓅 = Times@@(((Plus@@#& /@ℒ))^2)

MenageII[3]

Four couples, 297 pemutations:

MenageII[4]

MenageII[5]

MenageII[6]

For seven couples, the answer will take a while.

MenageII[7]

Third Approach...(best)

Explanation

One way to compute the number of complete permutations stated in the problem for, say, three couples is to compute the sixth-order term of the rook polynomial for the following board B, where the dark squares are permissible squares for the rooks to be placed.

Easier to compute is the rook polynomial for the following complementary board B'.

B' can be decomposed into the following sub-boards.

By convolving the rook polynomials for the sub-boards, we can compute the rook polynomial for B'; and by using the principle of inclusion and exclusion, we can compute the rook polynomial for the original board B.

In particular, we want (Subscript[r, 6])(B). The principle of inclusion and exclusion gives us the following formula:

\(TraditionalForm
    \`\(r\_6\)(B) = 
      \(6!\) - \(5!\)\ \(\(r\_1\)(B\^′)\) + 
        \(4!\)\ \(\(r\_2\)(B\^′)\) - 
        \(3!\)\ \(\(r\_3\)(B\^′)\) + 
        \(2!\)\ \(\(r\_4\)(B\^′)\) - 
        \(1!\)\ \(\(r\_5\)(B\^′)\) + 
        \(0!\)\ \(\(r\_6\)(B\^′)\)\)

We use convolution to compute the (Subscript[r, k])((B^′)), giving us the following:

\(TraditionalForm
    \`\(r\_k\)(B\^′) = 
      ∑\+\(a + b + c = k\)\(\(r\_a\)(B\_1\%′)\) 
          \(\(r\_b\)(B\_2\%′)\) \(\(r\_c\)(B\_3\%′)\)\)

For each sub-board (Subscript[B, i]^′), (Subscript[r, 0])((Subscript[B, i]^′))=1,(Subscript[r, 1])((Subscript[B, i]^′))=4, and (Subscript[r, 2])((Subscript[B, i]^′))=2, while every other (Subscript[r, k])((Subscript[B, i]^′))=0; so we make the following definitions.

r[0] = 1; r[1] = 4; r[2] = 2; r[_Integer] = 0;

Here we compute all of the partitions of the integers zero through six that have three or fewer elements, which gives us every a, b, c triple to use in the convolutions.

Needs["DiscreteMath`Combinatorica`"]

parts = 
      Flatten[Table[
          Select[Partitions[n, 2], Length[#] <= 3 && Plus@@# == n&], {n, 0, 
            6}], 1]

To make the zero terms explicit in the integer partitions, we pad each list with zeros.

padList[L_, n_] := With[{zl = Table[0, {n}]}, Take[Join[L, zl], n]]

padparts = Map[padList[#, 3]&, parts]

Each integer partition can be rewritten with its elements in several different arrangements; the number of different arrangements of a partition being the multinomial coefficients

(({{a + b + c}, {a, b, c}}))

which in Mathematica we express as Multinomial[a, b, c].

runLengths[L_] := Length/@Split[L]

(The Split command is new in Mathematica 3.0; users of Mathematica 2.2 and earlier should use the following definition instead.)

ppLengths = Map[runLengths, padparts, {1}]

multparts = Apply[Multinomial, ppLengths, 1]

Here we substitute the particular values of r in each term of the convolution.

rvalues = Apply[Times, Map[r, padparts, {2}], {1}]

Here are the signs used in the inclusion-exclusion step.

sgns = Map[(((-1))^Plus)@@#&, padparts]

Here we take care of all the multiplications in the inclusion-exclusion sum.

vals = sgns*rvalues*multparts

facts = Map[Factorial[6 - Plus@@#]&, padparts]

vals*facts

Adding together the list of terms gives us the number of possible rook placements.

Plus@@(vals*facts)

In the problem, people whose mates are sitting at the same table are treated as indistinguishable, so we must divide the total number of rook placements by two raised to the number of tables, in this case (2^3).

Plus@@(vals*facts)/(2^3)

Thus there are ten ways to seat six people so that no person is sitting at the same table as their (already seated) mate.

Combining the above steps into one function gives the following.

r[0] = 1; r[1] = 4; r[2] = 2; r[_Integer] = 0;

Needs["DiscreteMath`Combinatorica`"]

padList[L_, n_] := With[{zl = Table[0, {n}]}, Take[Join[L, zl], n]]

runLengths[L_] := Length/@Split[L]

For the function numberOfCPs, the argument n is the number of tables at the dinner party.

\(numberOfCPs[n_Integer] := 
	
      Module[{parts, padparts, ppLengths, multparts, rvalues, sgns, vals, 
          facts}, parts = 
          Flatten[Table[
              Select[Partitions[k, 2], 
                Length[#] ≤ n && Plus@@# == k&], {k, 0, 2\ n}], 
            1]; padparts = \((padList[#, n]&)\)/@parts; 
        ppLengths = Map[runLengths, padparts, {1}]; 
        multparts = Apply[Multinomial, ppLengths, 1]; 
        rvalues = Apply[Times, Map[r, padparts, {2}], {1}]; 
        sgns = \((\((\(-1\))\)\^Plus@@#&)\)/@padparts; 
        vals = sgns*rvalues*multparts; 
        facts = \(Factorial[2\ n - Plus@@#]\ &\)/@padparts; 
        Plus@@\((vals*facts)\)\/2\^n]\)

Here are the numbers of complete permutations corresponding to dinner parties with n tables, for n = 1, 2, …, 20.

numberOfCPs/@Range[20]

Here are the numbers of all permutations corresponding to dinner parties with n tables for  n = 1, 2, …, 20.

Table[(((2  n)!)/(2^n)), {n, 1, 20}]

Finally, the probabilities are computed that no two couples sit at the same table for n tables for  n = 1, 2, …, 20.

\(N[%%\/%]\)

For 100 tables, the probability is  0.134657. Notice, that

(E^(-2)) // N

Abs[(E^(-2)) - .134657]

The limit appears to be (E^(-2)).

(Code for diagrams)

rookrow = Flatten[Join[{Table[1, {2}], Table[0, {4}]}]];

rookgrid = 
      Reverse@Table[RotateRight[rookrow, 2  Floor[n/2 - 0.5]], {n, 6}];

ListDensityPlot[rookgrid, MeshStyle -> {GrayLevel[0.5]}, 
      Frame -> False, ImageSize -> 72, PlotLabel -> "B"];

\(\(ListDensityPlot[1 - rookgrid, MeshStyle -> {GrayLevel[0.5]}, 
      Frame -> False, ImageSize -> 72, 
      PlotLabel -> \*""\!\(B\^′\)""]; \)\)

\(\(Show[
      GraphicsArray[
        Block[{$DisplayFunction = Identity}, {
            ListDensityPlot[1 - rookgrid {0, 0, 0, 0, 1, 1}, 
              MeshStyle -> {GrayLevel[0.5]}, Frame -> False, 
              PlotLabel -> \*""\!\(B\_1\%′\)""], 
            ListDensityPlot[1 - rookgrid {0, 0, 1, 1, 0, 0}, 
              MeshStyle -> {GrayLevel[0.5]}, Frame -> False, 
              PlotLabel -> \*""\!\(B\_2\%′\)""], 
            ListDensityPlot[1 - rookgrid {1, 1, 0, 0, 0, 0}, 
              MeshStyle -> {GrayLevel[0.5]}, Frame -> False, 
              PlotLabel -> \*""\!\(B\_3\%′\)""]}]]]; \)\)

References

BLOM,G., Problems and Snapshots from the World of Probability, Springer-Verlag, 1991.

DOYLE, GRINSTEAD, and SNELLl, “Frustration solitaire” (version 1.0A5), 17 September 1994. Available at http://math.ucsd.edu/~doyle/docs/rank/rank/rank.html.

ROBERTS, F. S., Applied Combinatorics, Prentice-Hall, 1984, pp. 156–7, 162–3, 265–6.

SKIENA, S. S., Implementing Discrete Mathematics: Combinatorics and Graph Theory with Mathematica, Addison-Wesley, 1990, pp. 51–3.

NEW PROBLEM

For the next time, consider the much easier problem Making Change.

Write a function that will compute how many ways any amount of money X.Y
 (with X dollars, and Y cents) can be represented using any combination of US coins and bills up to
 the 100 dollar bill.The denominations are: penny, nickel, dime, quarter, half dollar, dollar, 2 dollar, 5 dollar,
10 dollar, 20 dollar, 50 dollar, 100 dollar.

For example:

Change[1.00]

292

Change[5.00]

59576

SUBMITTING PROBLEMS AND SOLUTIONS

Standard

CONTACTING THE EDITOR

Standard