in reply to Re^2: Derangements iterator (others) in thread Derangements iterator
(Re: Algorithm::Combinatorics) the logic in principle can be refined to skip some more permutations, but benchmarks showed no difference whatsoever, so I left the code that is easier to understand and added a comment about it:
/* I tried an alternative approach that would in theory avoid the
generation of some permutations with fixedpoints: keeping track of
the leftmost fixedpoint, and reversing the elements to its right.
But benchmarks up to n = 11 showed no difference whatsoever.
Thus, I left this version, which is simpler.
That n = 11 does not mean there was a difference for n = 12, it
means I stopped benchmarking at n = 11. */
The current interface guarantees lexicographic order, but I plan to provide more algorithms that relax that condition if you don't need it and faster generators are available. I will write it before I die ideally.
Re^4: Derangements iterator (order) by tye (Sage) on Jan 02, 2006 at 20:42 UTC 
Thanks for the explanation.
The current interface guarantees lexicographic order
It is easy to adjust my iterator to get lexicographic order. For example, just add one reverse:
$left= [ @$left, reverse @{$redo[$i]} ];
I plan to add a version to Algorithm::Loops before I die. (:
 [reply] [d/l] 

Here's a version you can add to Algorithm::Loops. It uses NestedLoops and is comparatively efficient about skipping invalid combinations. It also puts its results in numeric/lexicographic order and handles duplicates. The commentedout code is for watching/debugging the management of the "pool" of available numbers.
use strict;
use warnings;
use Algorithm::Loops 'NestedLoops';
sub derange {
# Generate the list of possible values at each position
# Skip a value if it's already used up (no more in the pool) or is i
+n its original position
my %pool;
++$pool{$_} for (@_);
my @orig = @_;
no warnings 'numeric';
my @values = sort {$a <=> $b or $a cmp $b} keys %pool;
my @prev_values;
NestedLoops(
[(sub {
# Generate all candidate values for this position
# print "Generating with \@_ = @_\n";
my $pos = @_;
# Update the pool: the last value on @_ has just changed, so
# return the previous value(s) to the pool and remove the new
# one.
if (@_) {
for (grep {defined $prev_values[$_]} $#_..$#orig1) {
#print "Returning $prev_values[$_] to the pool\n";
++$pool{$prev_values[$_]};
undef $prev_values[$_];
}
#print "Removing $_[1] from the pool\n";
$pool{$_[1]};
#print "Valid values in the pool:\n";
#while (my ($k,$v) = each %pool) {
# print "$k: $v\n" if $v;
#}
$prev_values[$#_] = $_[1];
}
[ grep {$orig[$pos] ne $_ and $pool{$_} > 0} @values ]
}) x @orig]
);
}
my @results;
my $iter = derange(@ARGV);
print "@results\n" while @results = $iter>();
As a possibly interesting note: if you simply remove $orig[$pos] ne $_ and, it becomes a permutations generator. But derange is not simply a permutations generator that filters out individual invalid permutations; it prunes entire subtrees. (Similarly, the permutation generator doesn't loop through the whole cartesian space and filter it.)
Caution: Contents may have been coded under pressure.
 [reply] [d/l] [select] 
