Services & ResourcesWolfram ForumsMathGroup Archive

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

RE: random derangement

• To: mathgroup at smc.vnet.net
• Subject: [mg37467] RE: [mg37416] random derangement
• From: "Wolf, Hartmut" <Hartmut.Wolf at t-systems.com>
• Date: Thu, 31 Oct 2002 04:42:00 -0500 (EST)
• Sender: owner-wri-mathgroup at wolfram.com

>-----Original Message-----
>From: DIAMOND Mark R. [mailto:dot at dot.dot]
To: mathgroup at smc.vnet.net
>Sent: Sunday, October 27, 2002 12:33 PM
>To: mathgroup at smc.vnet.net
>Subject: [mg37467] [mg37416] random derangement
>
>
>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
>
>
>
>
>
>
Mark,

the idea just to generate random permutations and then just drop those which
are no derangements has already been proposed by Rob Pratt. (I leave out
issues of compilation here.)


permutation[n_]:=Module[{deck=Range[n],newj},Do[newj=Random[Integer,{j,n}];
      deck[[{j,newj}]]=deck[[{newj,j}]],{j,n-1}];
    deck]

derangementQ[n_][perm_] := Not[Or @@ Equal @@@ Transpose[{Range[n ], perm}]]

derangement3[n_] := 
  Module[{p}, While[! derangementQ[n][p = permutation[n]]]; p]


This will then give equal probabilitiy to every derangement. We may
accelerate this, backing out, when a non-derangement _begins_ to evolve:

derangement4[n_] := 
  Module[{deck, newj}, 
    While[deck = Range[n]; Catch[Do[newj = Random[Integer, {j, n}];
          If[deck[[j]] == j == newj, Throw[True]]; 
          deck[[{j, newj}]] = deck[[{newj, j}]], {j, n}]]];
    deck]

This also gives equal probabilities. Interestingly this will work too:

derangement5[n_] := 
  Module[{deck, newj}, 
    While[deck = Range[n]; 
      Catch[Do[If[deck[[j]] == j, 
            If[Random[Integer, {j, n}] == n, Throw[True]]]; 
          newj = Random[Integer, {j + If[deck[[j]] == j, 1, 0], n}];
          deck[[{j, newj}]] = deck[[{newj, j}]], {j, n}]]];
    deck]

The line...

  If[Random[Integer, {j, n}] == n, Throw[True]]

...adjusts the probabilities in case of deck[[j]]==j and also checks for a
critical case when j == n.

--
Hartmut Wolf