#!/usr/bin/perl -w
use strict;

sub Iterator (&) { return $_[0] }
sub NEXTVAL { $_[0]->() }

### ==================================================================
### permute   (HOP1, 3.1)
### ==================================================================
sub permute {
    my @items = @{ $_[0] };
    my @perms = @{ $_[1] };
    my $fun   = $_[2] || sub { print "\t@{$_[0]}\n"; };
    unless (@items) {
        $fun->(\@perms); 
    } else {
        my (@newitems, @newperms, $i);
        foreach $i (0 .. $#items) {
            @newitems = @items;
            @newperms = @perms;
            # Remove #i item and prepend to perms; Permute new lists.
            unshift(@newperms, splice(@newitems, $i, 1));
            permute([@newitems], [@newperms], $fun);
        }
    }
}

### ==================================================================
### permute2   (HOP1   4,3.1)
### ==================================================================
sub permute2 {
  my @items = @_;
  my @pattern = (0) x @items;
  return Iterator {
    return unless @pattern;
    my @result = pattern_to_permutation(\@pattern, \@items);
    @pattern = increment_pattern(@pattern);
    return @result;
  };
}

sub increment_pattern {
  my @odometer = @_;
  my $wheel = $#odometer;    # start at rightmost wheel

  until ($odometer[$wheel] < $#odometer-$wheel  ||  $wheel < 0) {
    $odometer[$wheel] = 0;  
    $wheel--;  # next wheel to the left
  }
  if ($wheel < 0) {
    return;               # fell off the left end; no more sequences
  } else {
    $odometer[$wheel]++;  # this wheel now turns one notch
    return @odometer;
  }
}

sub pattern_to_permutation {
  my $pattern = shift;
  my @items = @{shift()};
  my @r;
  for (@$pattern) {
    push @r, splice(@items, $_, 1);
  }
  @r;
}

### ==================================================================
### permute_n   (HOP1   4,3.1)
### ==================================================================
sub permute_n {
  my @items = @_;
  my $n = 0;
  return Iterator {
    my @pattern = n_to_pat($n, scalar(@items));
    my @result = pattern_to_permutation(\@pattern, \@items);
    $n++;
    return @result;
  };
}

sub n_to_pat {
  my @odometer;
  my ($n, $length) = @_;
  for my $i (1 .. $length) {
    unshift @odometer, $n % $i;
    $n = int($n/$i);
  }
  return $n ? () : @odometer;
}


### ==================================================================
### permute-flop   (HOP1   4,3.1)
### ==================================================================
sub permute_flop {
  my @items = @_;
  my $n = 0;
  return Iterator {
    $n++, return @items if $n==0;
    my $i;
    my $p = $n;
    for ($i=1; $i<=@items && $p%$i==0; $i++) {
      $p /= $i;
    }
    my $d = $p % $i;
    my $j = @items - $i;
    return if $j < 0;

    @items[$j+1..$#items] = reverse @items[$j+1..$#items];
    @items[$j,$j+$d] = @items[$j+$d,$j];

    $n++;
    return @items;
  };
}

=cut
### -------------------------------------------------------
print "permute \n " . "-" x 40 . "\n";
my @col = [qw(white red orange yellow green blue violet black)];
my @res = [];
my $start = time();
#permute(@col, []);
permute(@col, [], sub { push @res, $_[0]; });
# print "@res\n";     #print Dumper( \@res );  
print time() - $start . " sec.\n";
=cut

### -------------------------------------------------------
print "increment_pattern \n " . "-" x 40 . "\n";
my @items = ('A' .. 'D');
my @pattern = (0) x @items;
while (@pattern = increment_pattern(@pattern) ) {
    print "@pattern\n";
    #print Dumper( \@pattern );
}

print "\npermute2 \n " . "-" x 40 . "\n";
my $pit = permute2('A' .. 'D');
while (my @p = NEXTVAL($pit)) {
    print "@p\n";
}
$pit = permute2( qw(red orange yellow green blue violet) );
while (my @p = NEXTVAL($pit)) {
    print "@p\n";
}

### -------------------------------------------------------
print "permute_n \n " . "-" x 40 . "\n";
my $it_n = permute_n('A' .. 'D');
while (my @p = NEXTVAL($it_n)) {
    print "@p\n";
}

### -------------------------------------------------------
print "permute_flop \n " . "-" x 40 . "\n";
my $it_f = permute_flop('A' .. 'D');
while (my @p = NEXTVAL($it_f)) {
    print "@p\n";
}
[download]