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