Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Re: random derangement

• To: mathgroup at smc.vnet.net
• Subject: [mg37449] Re: [mg37435] Re: [mg37416] random derangement
• From: Daniel Lichtblau <danl at wolfram.com>
• Date: Wed, 30 Oct 2002 00:50:56 -0500 (EST)
• References: <200210271133.GAA12182@smc.vnet.net> <200210290509.AAA27958@smc.vnet.net>
• Sender: owner-wri-mathgroup at wolfram.com

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

• References:
  • random derangement
    • From: "DIAMOND Mark R." <dot@dot.dot>
  • Re: random derangement
    • From: Daniel Lichtblau <danl@wolfram.com>