Mathematica Pearls:
Problems and Solutions

Edited by
Donald T. Piele
University of Wisconsin, Parkside
900 Wood Road
Kenosha, WI 53141
piele@cs.uwp.edu

Published in
Mathematica in Education and Research
Vol.4 No.1
Copyright 1995 TELOS/Springer-Verlag

A very active discussion was held recently on the MathGroup List 
concerning solutions to the Lottery problem: Simulate the random draw of 
6 different numbers from a bin filled with 42 numbers. Several original 
solutions were submitted. As luck would have it, the elementary problem 
posed in this column last time was a slightly more difficult version of 
the same problem. The challenge was to create a function SlickDeal[N,M] 
which deals out N hands of M cards each from a standard deck of 52 cards. 
Solutions that simulate the way cards are actually dealt after repeated 
shuffles and cuts were of particular interest.

Since the Lottery problem generated so much interest, and it sets the 
stage for the SlickDeal problem, lets begin with this problem.

Lottery

Lotto Problem (Source - Robert B. Love, MathGroup, Mon, 26 Dec 94, in 
[mg358] )

OK, time for a little fun. I can generate a list of random integers as 
Table[Random[Integer,{1,42}],{6}] and I get a list 6 elements long 
containing the integers from 1 to 42.  But how do I make sure no elements 
are repeated?

Solutions with Packages

A few people suggested using functions found in the package DiscreteMath.

<<DiscreteMath`Combinatorica`

(* by Benno Puetz *)
Lottery1[m_,n_]:=RandomKSubset[Range[1,n],m]
Lottery1[6,42]

(* <<DiscreteMath`Permutations` a subset of `Combinatorica`*)

(* by Richard Mercer and Robert Dickau *)
Lottery2[m_,n_]:= Take[RandomPermutation[n],m]
Lottery2[6,42]

It was also pointed out by Robert Dickau that by extracting the code 
written for RandomPermutation, one can write the following solution 
without the use of the package.

(* by extracting the code in DiscreteMath`Permutations` *)
Lottery3[m_,n_]:= Take[Map[#[[2]]&,Sort[Array[{Random[],#}&,n]]],m]
Lottery3[6,42]

This is a nice functional solution. It works by: constructing an array of 
random real numbers; indexing them from 1 to n; sorting the random real 
numbers which produces a random  permutation of the index numbers 1 to n; 
and picking off the first m integers in the permutation.

Solution by Trial and Error

There were several submission that used the idea of trial and error.

(* by Martin McClain *)
Lottery4[m_,n_]:=(len=0;While[len != m,
               hand = Table[Random[Integer,{1,n}],{m}];
               len = Length[Union[hand]]];
               hand);
 Lottery4[6,42]

A close examination of this solution shows that it would come to a hault 
if one tried to select 40 numbers from 42 instead of 6. It is very 
unlikely that 40 random integers from 1 to 42 will be unique.

Procedural solutions

A typical Pascal or C language solution to the Lottery problem would be 
to pick a random number from the list of numbers, delete it from the list 
and repeat the process on the smaller list until all m random numbers are 
selected. Here are some examples using this strategy.

(* by Lou Talman *)
Lottery5[m_,n_]:=
   (num = Range[n]; 
    Table[j = Random[Integer, {1, n}];
          k = num[[j]];
          num = Delete[num, j];
          k, {m}]);

Lottery5[6,42]

(* by Donald Darling *)
Lottery6[m_,n_]:=(S={};CS=Range[n];For[j=1,j<=m,j++,
             AppendTo[S,x={CS[[ Random[Integer,{1,n-j+1}] ]]}];
             CS=Complement[CS,x] ];Flatten[S])
Lottery6[6,42]

(* by Steve Skiema. Taken from his algorithm in the package:
 DiscreteMath`Combinatorica` for RandomKSubsets and applied to this
problem.*)
Lottery7[m_,n_]:=(s=Range[n];
               Table[x=Random[Integer,{1,i}];
               {s[[i]],s[[x]]}={s[[x]],s[[i]]};
               s[[i]],{i,n,n-m+1,-1}])

Lottery7[6,42]

Rewrite Rule Solution

Here is a rewrite rule solution which uses trial and error to build up  
the desired list. It of course would slow down for large m.

(* by Tyler Perkins *)
rules[num_, range_] = {
    (*  Rule #1:
        Delete any repetition.  
        Only need to look at last element! *)
    { s1___, e_, s2___, e_ } :> { s1, e, s2 },
    
    (* Rule #2:
       Otherwise append a new random number 
       until long enough.*)
       
    {elems___} :> {elems, Random[Integer, {1,range}]} 
                  /; Length[{elems}] < num
};

Lottery8[m_,n_]:= {} //. rules[m,n]
Lottery8[6,42]

The shuffle solution

We can use the idea submitted by Tom Fournelle for creating a good card 
shuffle program (see SlickDeal below), to solve the Lottery problem as 
follows: Consider the numbers as cards from 1 to 42. Mix[numbers] by 
doing a perfect shuffle followed by a random cut (RotateLeft). Nest this
process 10 times and (Take) the top 6 numbers.

(* extracted from Tom Fournell's SlickDeal solution *)
Mix[x_List]:=RotateLeft[Transpose
            [Partition[x,Length[x]/2]]//Flatten,      
            Random[Integer,{1,Length[x]}]]

Lottery9[m_,n_]:=Take[Nest[Mix[#]&,Range[n],10],m]
Lottery9[6,42]

Graphic Solution

Finally, we end the discussion of the Lottery problem by generating a 
graphics model of the random selection process.

Needs["Graphics`Graphics3D`"]

(* selection the bin locations, create graphics *)
randpos[n_]:= Table[Random[], {n}, {3}];
bin[n_,s_]:=ScatterPlot3D[randpos[n],
            DisplayFunction->Identity] /. {x__Point -> 
		    {Hue[s], PointSize[0.05], x} ,
		    Identity->$DisplayFunction}

LotteryG[m_,n_]:=(Show[bin[m,.1],bin[n-m,.5]];  (*Show all balls*)

(*Select Random numbers*)
rannums=Take[Map[#[[2]]&,Sort[Array[{Random[],#}&,n]]],m];

(*Select coordinates for m balls *)
balls=Table[Point[{i,0.}], {i,m}];

(*Put numbers into text to be placed on balls *)
textnums=Table[Text[rannums[[j]],{j,0}],{j,m}];

(*Display balls with random numbers*)
Show[Graphics[{{Hue[.1],PointSize[.05],balls},textnums}]] 
)
LotteryG[6,42]

SlickDeal

Elementary Problem E3: Slick Deal. Create a function SlickDeal[n,k] which 
will deal out n hands of k cards each from a standard deck of cards. The 
solution will be judged on how well it simulates the way cards are 
actually dealt after repeated shuffles and cuts. For cards use:

Clear[c,d,h,s]
numbers = Range[2,10]~Join~{J,Q,K,A};
suit = {c,d,h,s};
cards = Distribute[{numbers,suit}, List]

Solution by Stan Wagon, Macalester College.

See Stan's column in this issue for a discussion on how to consturct the 
graphics for making  cards.

(* The <<DiscreteMath`Combinatorica`  needs to be loaded for 
RandomKSubsets *)

SlickDeal[n_, k_] := Module[
                 {hands = Table[Null, {n}],
                  cards = Distribute[List[{c,d,h,s}, 
                  Join[Range[2,10], {J,Q,K,A}]], List]},

Do[hands[[i]] = RandomKSubset[cards, k];
   cards = Complement[cards, hands[[i]]], {i, n}];
   hands]

SlickDeal[4,5]//TableForm

Solution by Tom Fournelle, University of Wisconsin-Parkside

Tom's solution tries to simulate the way cards are mixed up by making 
repeated shuffles and cuts. Each shuffle is a perfect shuffle and each 
cut is made at random between the 10th and 42ed card. The second time the 
deck is shuffled the slickDeal begins with the shuffled state of the deck 
and not with the orginal ordered set of cards.

Cutting and shuffling the cards.

cut[cards_]:= 
       RotateLeft[cards,Random[Integer,{10,42}]]
       
shuffle[cards_]:=
       Flatten[Partition[cards,26]//Transpose,1]
       
cards=Distribute[{{c,d,h,s},Range[2,10]~Join~{J,Q,K,A}},List];
deck=cards;

Dealing  n  hands of  k  cards each after cutting and shuffling a random 
number of times.

slickDeal[n_,k_]:=Module[{numcuts},
  
	numcuts= Random[Integer,{6,12}];
    deck=Nest[shuffle[cut[#]]&,deck,numcuts];
     
    Take[Partition[deck,k],n]]

slickDeal[4,5]//TableForm

It would be interesting to speculate which of these two methods comes 
closest to our human experience. Ross Moore pointed out,  "In practice 
hand-shuffled deals are NOT RANDOM. After just 2 or 3 riffles and a cut, 
it becomes virtually impossible to predict what will be dealt to whom. 
However there are bound to be many correlations between (i) certain pairs 
of cards in the new deal; and (ii) how they were played on the previous 
deal using the same deck.

Comments by Ross Moore

It is an on-going problem in the bridge fraternity as to whether the 
computer programs that are being used actually work properly -- that is, 
produce "random hands".

Let us get an appreciation for the essence of the problem. 52! is a big 
number:  8.06582... x 10^67. Divide by (13!)^4 if you like --we are still 
pretty big at:  5.36447 x 10^28.

The MINIMUM requirement of our random number generator is that it 
generate at least this many distinct random numbers. Note that I state 
this as a requirement of the `random number generator', not of the 
dealing algorithm.

Since a random number generator(RNG) can be `seeded' to guarantee that it 
produces the same sequence of (pseudo-)random numbers,  then the seeding 
function needs to be able to accept at least as many seeds that produce 
different (sequences of) numbers as there are elements
in the sample space (i.e. distinct deals, hence 10^(28+) ).

We would also like each deal to be equally likely as any other, so some 
sort of uniformity of distribution is also required.

However a dealing program needs to be able to do even more than this. 
Given one deal then the next should be entirely independent; that is, 
each deal should have equal probability of occurrence after any other. 
Thus we need to be able to produce ( 10^(28+) )^2 distinct random numbers.

A typical tournament session normally needs at least 24 deals; it is 
common to produce 32. World championship matches can be much longer.

So to satisfy the purists, we need to be able to generate  ( 10^(28+) 
)^32 distinct random numbers. My understanding is that such things DO NOT 
EXIST on present day computers.

New Problem

The Lottery problem received the kind of participation I have been hoping 
for in this column---but have been unable to achieve. The advanced 
problem posed last time got no response. Therefore, I am dropping the 
advanced problem and posing one more approachable and solvable problem of 
interest to a wider audience.  So send in those Pearls, I need more.  
I'll also pick up a few along the way by keeping an eye on the MathGroup.

SuperPrime Rib

Butchering Farmer John's cows always yields the best prime rib.  You can 
tell prime ribs by looking at the digits lovingly stamped across them, 
one by one, by FJ and the USDA.  Farmer John ensures that a purchaser of 
his prime ribs gets really prime ribs because when sliced from the right, 
the numbers on the ribs continue to stay prime right down to the last 
rib, e.g.,

7 3 3 1

The set of ribs 7331 is prime; the three ribs 733 are prime; the two ribs 
73 are prime, and, of course, the last rib, 7, is prime.  The number 7331 
is called a superprime of length 4.

Create a funciton superPrime[N] that accept sN ribs and prints all the 
superprimes of length N.

superPrime[4]

{2333, 2339, 2393, 2399, 2579, 2939, 3119, 3137, 3733, 3739, 
3793, 3797, 5939, 7193,  7331, 7333, 7393}