a b b a
####
b a a b
##
##
use strict;
use warnings;
# The recursive one
sub derange {
# First argument is optional arrayref of original values; if not provided,
# build it from arg list
my @orig = ref $_[0] ? @{shift(@_)} : @_;
if (@_ == 0) { return [] }
if (@_ == 1) {
return $_[0] eq $orig[0] ? () : [$_[0]];
}
# Generate a derangement by extracting each element then mapping it as the head
# to the derangement of the everything else
# Swaps that would cause a value to match its corresponding original value are skipped
my %seen;
map {
if ($orig[$_] ne $_[0] and $orig[0] ne $_[$_] and not $seen{$_[$_]}++) {
my $swap_i = $_;
map [$_[$swap_i], @$_]
, derange([@orig[1..$#orig]], @_[0..$swap_i-1,$swap_i+1..$#_]);
}
else {
();
}
} (0..$#_);
}
# The iterator version
sub derange_iter {
# First argument is optional arrayref of original values; if not provided,
# build it from arg list
my @orig = ref $_[0] ? @{shift(@_)} : @_;
# Base cases get assigned to an array, which the iterator shifts through
if (@_ == 0) {
my @base_case = ([]);
return sub { shift @base_case };
}
elsif (@_ == 1) {
my @base_case = $_[0] eq $orig[0] ? () : [$_[0]];
return sub { shift @base_case };
}
# otherwise..
my %seen;
my @list = @_;
my @sub_iter = map {
if ($orig[$_] ne $list[0] and $orig[0] ne $list[$_] and not $seen{$list[$_]}++) {
my $swap_i = $_;
sub {
my $cdr_iter = derange_iter([@orig[1..$#orig]], @list[0..$swap_i-1,$swap_i+1..$#list]);
sub {
my $cdr = $cdr_iter->();
if ($cdr) { return [$list[$swap_i], @$cdr] }
else { return () }
};
}
}
else {
();
}
} (0..$#_);
# Grab and unwrap an iterator from the list
my $iter = (shift @sub_iter)->();
return sub {
my $rval;
$iter = (shift @sub_iter)->()
until ($rval = $iter->() or @sub_iter == 0);
return $rval;
}
}
@ARGV or @ARGV = 1..5;
my $i = derange_iter(@ARGV);
for (1..50) {
my $val = $i->() or last;
print "@$val\n";
}
#print "\nShould be:\n";
#print "@$_\n" for sort {"@$a" cmp "@$b"} derange(@ARGV);