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>