use strict;
use warnings;

# The recursive one
sub derange {
  # First argument is optional arrayref of original values; if not pro
+vided,
  # 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 pro
+vided,
  # build it from arg list
  my @orig = ref $_[0] ? @{shift(@_)} : @_;

  # Base cases get assigned to an array, which the iterator shifts thr
+ough
  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);
[download]