RE: Re: Re: random derangement
- To: mathgroup at smc.vnet.net
- Subject: [mg37455] RE: [mg37449] Re: [mg37435] Re: [mg37416] random derangement
- From: "DrBob" <drbob at bigfoot.com>
- Date: Thu, 31 Oct 2002 04:40:47 -0500 (EST)
- Reply-to: <drbob at bigfoot.com>
- Sender: owner-wri-mathgroup at wolfram.com
Unless I'm mistaken, a derangement can't leave any card in its original
position. If so, that code doesn't always do it.
derangement = Compile[{{
n, _Integer}}, Module[{deck =
Range[n], newj}, Do[newj = Random[Integer, {j + If[
deck[[j]] == j, 1, 0], n}];
deck[[{j, newj}]] = deck[[{newj, j}]], {j, n - 1}];
deck]];
check[deck_] := Count[Transpose[{deck, Range@Length@deck}], {a_, a_}] ==
0
And @@ Table[check@derangement[15], {100}]
False (* usually *)
Here's code that does:
derangement = Compile[{{n, _Integer}},
Module[{deck = Range[n], newj},
Do[
While[deck[[newj = Random[Integer, {1, n}]]] == j
|| newj == deck[[j]]];
deck[[{j, newj}]] = deck[[{newj, j}]],
{j, n}
];
deck]];
And @@ Table[check@derangement[15], {1000}]
True
DrBob
-----Original Message-----
From: Daniel Lichtblau [mailto:danl at wolfram.com]
To: mathgroup at smc.vnet.net
Subject: [mg37455] [mg37449] Re: [mg37435] Re: [mg37416] random derangement
Daniel Lichtblau wrote:
>
> "DIAMOND Mark R." wrote:
> >
> > This is not quite aposite to either NG, but there appear to be none
better
> > ... My apologies.
> >
> > I am searching for an algorithm for producing a random derangement
of, for
> > instance, the integers 1 to approx 10000.
> >
> > I thought Skiena's site might have such an algorithm, but I could
not locate
> > one. ... Producing all derangements and choosing one at random is
marginally
> > beyond the capacity of my machine :-)
> >
> > Cheers,
> >
> > Mark R. Diamond
>
> One thing that will work efficiently is a modification of a basic
random
> shuffle. The basic shuffle can be found at
>
> http://forums.wolfram.com/mathgroup/archive/2001/Apr/msg00263.html
>
> The modification is that at step j we insist on moving something
between
> position j+1 (rather than j) and the end into position j.
>
> derangement = Compile[{{n,_Integer}}, Module[
> {deck=Range[n], newj},
> Do[
> newj = Random[Integer, {j+1,n}];
> deck[[{j,newj}]] = deck[[{newj,j}]],
> {j,n-1}];
> deck
> ]]
>
> In[4]:= Timing[dd = derangement[10^6];]
> Out[4]= {5.25 Second, Null}
>
> Check that this is indeed a derangement:
>
> In[5]:= Select[Transpose[{dd,Range[10^6]}], #[[1]]==#[[2]]&]
> Out[5]= {}
>
> (Or you can use MapIndexed for this test):
> In[12]:= Apply[Or, MapIndexed[#1==#2[[1]]&, dd]]
> Out[12]= False
>
> I think this will give random derangements with equal probabilities
> though I don't have a proof of that off the top of my head.
>
> Daniel Lichtblau
> Wolfram Research
Oops...my code was itself a bit deranged insofar as it will not hit all
possible derangements. I think the version below will do better.
derangement = Compile[{{n,_Integer}}, Module[
{deck=Range[n], newj},
Do[
newj = Random[Integer, {j+If[deck[[j]]==j,1,0],n}];
deck[[{j,newj}]] = deck[[{newj,j}]],
{j,n-1}];
deck
]]
Daniel Lichtblau
Wolfram Research