Re: random derangement

*To*: mathgroup at smc.vnet.net*Subject*: [mg37435] Re: [mg37416] random derangement*From*: Daniel Lichtblau <danl at wolfram.com>*Date*: Tue, 29 Oct 2002 00:09:36 -0500 (EST)*References*: <200210271133.GAA12182@smc.vnet.net>*Sender*: owner-wri-mathgroup at wolfram.com

"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

**Follow-Ups**:**Re: Re: random derangement***From:*Daniel Lichtblau <danl@wolfram.com>

**References**:**random derangement***From:*"DIAMOND Mark R." <dot@dot.dot>