package SecondPermute;
###############################################################
#
# A perl algorithm to generate all permuations of an array.
#
# Usage:
#
#   (1) From another perl script :
#
#         use SecondPermute qw( permute );
#         permute( 
#           sub { print " @_ \n" }, 
#           'a'..'d'
#         );
#
#   (2) From the command line (does tests and benchmarks) :
#       
#         $ perl SecondPermute.pm
#
#
# The algorithm works by moving each element in turn
# from an input list to the right end of an output list, 
# and then calling the same algorithm recursively on what remains
# of the input.  The recursion descent terminates when the input list
# is empty.  After each recursive call, the element which 
# was moved to the output is moved back to the input, 
# into the same spot where it came from.  The entire process is done in place, 
# and relying heavily (in this implementation) on perl's "splice" function.
#
# Visually it looks like this for n=3.
# On the left, the * marks the number which will be moved 
# to the output list next.
# 
#    input                        output          answer
#    depth=1  2      3     4
#    ------------------------     -----------
#    (*1 2 3)                     ()
#             (*2 3)              (1)
#                    (*3)         (1 2)
#                          ()     (1 2 3)         <=
#                    (3)          (1 2)
#             (2 *3)              (1)
#                    (*2)         (1 3)
#                          ()     (1 3 2)         <=
#                    (2)          (1 3)
#             (2 3)               (1)
#    (1 *2 3)                     ()
#             (1* 3)              (2)
#                    (*3)         (2 1)
#                          ()     (2 1 3)         <=
#                    (3)          (2 1)
#             (1 *3)              (2)
#                    (1)          (2 3)
#                    ()           (2 3 1)         <=
#                    (1)          (2 3)
#             (1 3)               (2)
#    (1 2 *3)                     ()
#             (1* 2)              (3)
#                    (*2)         (3 1)
#                          ()     (3 1 2)         <=
#                    (2)          (3 1)
#             (1 *2)              (3)
#                    (1)          (3 2)
#                    ()           (3 2 1)         <=
#                    (1)          (3 2)
#             (1 2)               (3)
#    (1 2 3)                      ()
#
#
# $Id: SecondPermute.pm 109 2005-01-29 05:55:19Z mahoney $
##################################################################
use strict;
use warnings;
use base 'Exporter';
our @EXPORT_OK = qw( permute );

my @input;         # input original array
my @output;        # output permuted array
my $sub;           # subroutine to be applied to each permutation

sub permute {
  ($sub, @input) = @_;
  recursive_permute();
}

sub recursive_permute {
  unless (@input){
    $sub->(@output);
    return;
  }
  for (my $i=0; $i<@input; $i++){
    push @output, splice(@input,$i,1);
    recursive_permute();
    splice(@input, $i, 0, pop @output);
  }
}

my $verbose = 1;

sub test {
  use Test::More 'no_plan';
  print "-"x10 .  " tests " . "-"x10 . "\n";
  ok( 720 == factorial(6), '6! is 720');
  my $n = 6;
  print "factorial(6) = " . factorial(6) . "; should be 720.\n" if $verbose;
  my @array = 1..$n;
  my @results;
  my %unique;
  my $proc = sub {
    push @results, [@_];   # keep each permutation
    $unique{"@_"}++;       # see if they're all unique
  };
  print "Collecting results of permuting ( @array ) ..\n" if $verbose;
  permute( $proc, 1..$n );
  print "done.\n" if $verbose;
  print "Saw " . scalar(@results) . " results.\n" if $verbose;
  print "Number of unique ones is " . scalar(keys %unique) . ".\n" if $verbose;
  print "Expected " . factorial($n) . ".\n" if $verbose;
  ok( scalar(@results)==factorial($n), "permute($n) gives ".factorial($n)." results");
  ok( scalar(keys %unique)==factorial($n), "all unique");
  my $allValid = 1;
  foreach my $result (@results){
    for (my $i=0; $i<$n-1; $i++){
      for (my $j=$i+1; $j<$n; $j++){
	# print " i=$i, j=$j\n";
	if ($result->[$i] eq $result->[$j]){
	  $allValid = 0;
	  print "oops - @{$result} isn't valid. \n" if $verbose;
	}
      }
    }
  }
  ok( $allValid, "all with $n different digits");
  print "None of the permutations have duplicate entries.\n" if $allValid && $verbose;
  if ($verbose){
    print "Here they are :\n";
    foreach my $r (@results){
      print " @{$r} \n";
    }
  }
}

sub factorial {
  my ($n) = @_;
  my $result = 1;
  while ($n>0){
    $result *= $n;
    $n--;
  }
  return $result;
}

# Perl's Benchmark.pm can generate timing statistics.
sub benchmark {
  use Benchmark qw( :all :hireswallclock );
  print "-"x10 .  " benchmarks " . "-"x10 . "\n";
  # the -2 here means "repeat for at least 2 seconds"
  if ($verbose){
    my $answer = cmpthese( -2, {
				'n=4' => sub { permute( sub {}, 1..4) },
				'n=5' => sub { permute( sub {}, 1..5) },
				'n=6' => sub { permute( sub {}, 1..6) },
				'n=7' => sub { permute( sub {}, 1..7) },
				'n=8' => sub { permute( sub {}, 1..8) },
				'n=9' => sub { permute( sub {}, 1..9) },
			       }
			 );
    print "n=5 in detail:\n";
    my $result = timethis( -2, sub { permute( sub {}, 1..5) }, "n=5", 'none' );
    use Data::Dumper;
    print " timethis returns " . Dumper($result);
    # results are ($real, $user, $system, $children_user, $children_system, $iters)
    # in seconds for the whole loop (not divided by the number of rounds).
    # i.e.. $result->[0] = wall clock
    #       $result->[1] = usr time
    #       $result->[5] = repititions
    print " or " . timestr($result) . "\n";
    my $secs = $result->[1]/$result->[5];
    printf(" implying %6.3g seconds = %6.3f/s \n", $secs, 1/$secs);
  }
  for my $n (4..10){
    my $answer = timethis( -8, sub { permute( sub {}, 1..$n) }, "n=$n", 'none' );
    printf(" n=%2i : %6.3g seconds.\n", $n, $answer->[1]/$answer->[5] );
  }
  print "-"x20 . "\n";
}

test(), benchmark() unless caller();

1;
