From: Jim Ferry <jferry@delete_this_field.uiuc.edu>
Subject: Re: difficult probability
Date: Wed, 10 Feb 1999 12:01:48 -0600
Newsgroups: sci.math
Keywords: probability that adjacent cards have different values

Max J. Mammel wrote:
> 
>         Can anyone determine the probability that a well-shuffled deck
> of 52 cards has no cards of the same value adjacent to each other?  In
> other words, as you go through the deck an ace will never be followed
> by another ace, a two will never be followed by another two and so on.
> If you actually experiment with a real deck it seems extremely
> unlikely.

I get a probability of about 1/21.99, in agreement with Clive
Tooth's Monte Carlo result.  The Mathematica transcript below
gives the exact number of valid permutations, the exact
probability, and an approximation of 1 / probability.

In[4]:= s[4,13]

Out[4]=
3668033946384704437729512814619767610579526911188666362431432294400

In[5]:= % / 52!

         672058204939482014438623912695190927357
Out[5]= -----------------------------------------
        14778213400262135041705388361938994140625

In[6]:= N[1/%,16]

Out[6]= 21.98948438043828

---------

Here's the code I used:

$RecursionLimit = 512;

s[nsuits_,nvals_] := Block[{},
  n = nsuits;
  zer = Table[0,{n-1}];
  sub[Join[zer,{0,nvals}],nsuits+1]
];

sub[arr_,j_] := If[Select[arr,Negative,1] != {}, 0,
  If[j==1 && Drop[arr,2] == zer, (arr[[2]]-1)(arr[[2]]-1)!,
    sub[arr,j] = Block[{k,md,tot},
      md = {1,-1}~Join~zer;
      For[tot=0;k=1,k<=n,k++, tot +=
        k (arr[[k+1]] + If[j==k,-1,0]) sub[arr + md,k-1];
        md = RotateRight[md,1];
      ]; tot]]];

|             Jim Ferry              | Center for Simulation  |
+------------------------------------+  of Advanced Rockets   |
| http://www.uiuc.edu/ph/www/jferry/ +------------------------+
| jferry@expunge_this_field.uiuc.edu | University of Illinois |
==============================================================================

From: Jim Ferry <jferry@delete_this_field.uiuc.edu>
Subject: Re: difficult probability
Date: Thu, 11 Feb 1999 13:23:21 -0600
Newsgroups: sci.math

QSCGZ wrote:
>
>  >Max J. Mammel wrote:
>  >>         Can anyone determine the probability that a well-shuffled deck
>  >> of 52 cards has no cards of the same value adjacent to each other?
>
> I'd be interested in the concrete recursion formula , that you used.
> I can't easily extract it from the Mathematica-code .
> 
> Is there a possible generalization which allows to find the number
> of strings without repeats (or "2-runs" or "adjacent values")
> and with a_i occurrences of letter i (i=1..values) ?

Let s denote the number of suits of a deck, and v the number
of "values" ( = A, 2, 3, ...) or "letters."  (I like your word
"letters" better, but I'll use "v," not "l.")  Imagine the deck
consisting of s A's, s 2's, etc, but without suit markers, so
that, e.g., the total number of permutations is (sv)!/s!^v.

Let a "valid permutation" be one for which there are no runs of
k of cards with the same letter.

Let b(a0,a1,...,as;j,q) = The number of valid permutations with

  0 cards each in a0 of the letters,
  1 card  each in a1 of the letters,
    . . ., and
  s cards each in as of the letters

such there are j cards remaining of the value last played, and
the string of consecutive cards played has length q.

If there are no previous values played, we can set j=0, so that
if p(s,v) = the number of valid permutations for the deck, then

p(s,v) = b(0,0,...,v;0,1).

The probability of a valid deck is just p(s,v) s!^v / (sv)!.

Assuming k > 1, the recursion for b is

b(a0,a1,...,as;j,q) =
  a1 b(a0+1,a1-1,a2,...,as;0,1) +
  a2 b(a0,a1+1,a2-1,...,as;1,1) +
    . . .
  as b(a0,a1,...,a(s-1)+1,as-1;s-1,1),

*except* that the term

  aj b(a0,a1,...,a(j-1)+1,aj-1,...,as;j-1,1)

is replaced by

  (aj-1) b(a0,a1,...,a(j-1)+1,aj-1,...,as;j-1,1) +

  (  b(a0,a1,...,a(j-1)+1,aj-1,...,as;j-1,q+1)  if q+1 < k,
  <
  (  0                                          otherwise.

Here is a revised Mathematica code:

$RecursionLimit = 512;

p[nsuits_,nvals_,k_] := Block[{},
  n = nsuits;
  zerm = Table[0,{n-1}];
  zer = Table[0,{n}];
  b[Append[zer,nvals],0,1,k]
];

b[arr_,j_,q_,k_] := If[Select[arr,Negative,1]!={},0,
If[j==0&&Drop[arr,1]==zer,1,b[arr,j,q,k]=Block[{i,md,
tot},For[tot=0;md={1,-1}~Join~zerm;i=1,i<=n,md=
RotateRight[md,1];i++,tot+=If[i==j,(arr[[i+1]]-1)*
b[arr+md,i-1,1,k]+If[q+1<k,b[arr+md,i-1,q+1,k],0],
arr[[i+1]]b[arr+md,i-1,1,k]];];tot]]];

prob[s_,v_,k_] := p[s,v,k]/((s*v)!/s!^v);
r[s_,v_,k_] := p[s,v,k] / v!;

|             Jim Ferry              | Center for Simulation  |
+------------------------------------+  of Advanced Rockets   |
| http://www.uiuc.edu/ph/www/jferry/ +------------------------+
| jferry@expunge_this_field.uiuc.edu | University of Illinois |