Re: Array Shuffle

A derangement is just a mapping from every element of a set to some other element of the set. The simplest derangement is to map each element to its neighbor. And if you randomize the list before doing that mapping, you have a random derangement (mapping). You can then use that mapping on the original list to get a derangement of the original list.

use strict;
use warnings;

my @array = (1..9);

sub derange {
  use List::Util 'shuffle';
  my @list = shuffle @_;
  my %map = map {($list[$_-1] => $list[$_])} 0..$#list;
  print "@map{@_}\n";
}

print "@array\n";
derange(@array) for 1..15;
[download]

You'll see that in the output, no element appears in its original position (after the first line, which is there for reference).

One slightly non-obvious thing I did was to use negative indexing so that my mapping would wrap around from the last element to the first.

Caution: Contents may have been coded under pressure.

Comment on Re: Array Shuffle Download Code

Replies are listed 'Best First'.
Re^2: Array Shuffle by ambrus (Abbot) on Feb 28, 2006 at 21:54 UTC
That works well for 3 elements, but for 4, there are some derangements it never generates, for example (2, 1, 4, 3).	[reply]
Re^3: Array Shuffle by Roy Johnson (Monsignor) on Mar 01, 2006 at 15:41 UTC
An astute observation. For those who wonder why, it's because the mapping required to produce 2 1 4 3 is 1 => 2, 2 => 1, 3 => 4, 4 => 3, and my mapping is a big cycle. If I get a bit of time to work on it, I'll post some updated code that allows for subcycles. Update (again: previous code that appeared here was broken): If you modify the Fisher-Yates algorithm to force every element to swap with a higher element (instead of possibly "swapping" with itself), then almost all derangements are possible; all derangements become possible (thought not equally likely) if you use a random position in the list as the first location to swap from, and allow some swaps to be skipped if the candidates are already deranged. use strict; use warnings; sub derange { my @list = @_; # Swap every element with something higher my $start = int rand @list; for (0..($#list-1)) { my $this = ($start + $_) % @_; next if $list[$this] ne $_[$this] and $_ < $#list-1 and rand > .52 +; my $other = $_ + 1 + int rand($#list - $_); $other = ($start + $other) % @_; @list[$this,$other] = @list[$other,$this]; } "@list"; } my @ar = ('a'..'d'); print "@ar\n"; my %countem; $countem{derange @ar}++ for 1..5000; print "$_: $countem{$_}\n" for (sort keys %countem); [download] Caution: Contents may have been coded under pressure.	[reply] [d/l]