I've been researching recursion lately and in particular, permutations algorithms. This interest was spurred by a reallife case where such an algorithm would come in handy (combinations of @clients, @users, @tickets). I came across Wikipedia's entry for Heap's algorithm and the pseudocode illustrating the algorithm. I found the nonrecursive version even more interesting specifically for its lack of needing to call itself, so I chose that version of the algorithm to study.
I thought it would be an interesting exercise to convert the pseudocode to Perl code. While I was converting it I was struck by how closely the Perl code could be made to look like the pseudocode, but also how easy idiomatic Perl made it to skip certain parts of the pseudocode altogether, so I wrote two separate Perl implementations of the algorithm: one to mirror the pseudocode as closely as possible, and one to cut corners using idiomatic Perl.
First, the "pseudocode" version:
 sub output {
 my (@to_print) = @_;
 print join( ',', @to_print ), "\n";
 }
 sub is_even {
 return $_[0] % 2 ? 0 : 1;
 }
 # By referring to $_[0] and $_[1] instead of assigning their values to other
 # variables, we can force passbyreference here so that the change will
 # impact @A directly even though we are in a separate function outside its
 # scope.
 sub swap {
 ($_[0],$_[1]) = ($_[1],$_[0]);
 }
 sub generate {
 my ($n, @A) = @_;
 my @c;
 for ( my $i = 0; $i < $n; $i += 1 ) {
 $c[$i] = 0;
 }
 output(@A);
 my $i = 0;
 while ( $i < $n ) {
 if ( $c[$i] < $i ) {
 if ( is_even($i) ) {
 swap( $A[0], $A[$i] );
 }
 else {
 swap( $A[ $c[$i] ], $A[$i] );
 }
 output(@A);
 $c[$i] += 1;
 $i = 0;
 }
 else {
 $c[$i] = 0;
 $i += 1;
 } # end if
 } # end while
 }
 generate( 3, 'work', 'sleep', 'play' );
Output:
work,sleep,play
sleep,work,play
play,work,sleep
work,play,sleep
sleep,play,work
play,sleep,work
Next, the idiomatic Perl version:
 sub output {
 print join( ',', @_ ), "\n";
 }
 sub generate {
 # We don't need to pass n here because we have @A. That's not at all
 # unique to Perl of course but the cool part comes later...
 my (@A) = @_;
 # I don't need to specify the length of array @c because as soon as we
 # refer to an element, it exists. I don't need to initialize @c or $i
 # because as soon as we start performing math on their values they will be
 # assumed to start at zero.
 my (@c,$i);
 output(@A);
 # The cool part: we can refer to the length of the @A array as simply @A
 # in scalar context.
 while ( $i < @A ) {
 if ( $c[$i] < $i ) {
 # Test for is_odd by seeing if modulo 2 of $i is nonzero.
 # Since we check for is_odd vs is_even, we swap the code in the
 # ifelse.
 if ( $i % 2 ) {
 # The swap function was handy but idiomatic Perl allows us to
 # swap variables in place
 ( $A[ $c[$i] ], $A[$i] ) = ( $A[$i], $A[ $c[$i] ] );
 }
 else {
 ( $A[0], $A[$i] ) = ( $A[$i], $A[0] );
 }
 output(@A);
 # Nitpicky but it's nice to have ++ instead of += 1. Again, not
 # limited to Perl.
 $c[$i]++;
 $i = 0;
 }
 else {
 $c[$i] = 0;
 $i++;
 }
 }
 }
 generate( split '', 'abc' );
Output:
a,b,c
b,a,c
c,a,b
a,c,b
b,c,a
c,b,a
In what ways could the program be further reduced?
EDIT: A change by an anonymous commenter makes this even more compact:
 sub output {
 print join( ',', @_ ), "\n";
 }
 sub generate {
 my (@A) = @_;
 output(@A);
 while ( $i < @A ) {
 if ( $c[$i] < $i ) {
 my $x = $i % 2 ? $c[ $i ] : 0;
 ( $A[ $x ], $A[$i] ) = ( $A[$i], $A[ $x ] );
 output(@A);
 $c[$i]++;
 $i = 0;
 }
 else {
 $c[$i] = 0;
 $i++;
 }
 }
 }
 generate( split '', 'abcd' );
2 comments:
Consider allowing the use of "pre" tag for code.
Diff follows ...
Simply find the index to use instead of repeating swap ops.

heap.pl  11 ++
1 file changed, 2 insertions(+), 9 deletions()
diff git heap.pl heap.pl
index 5ba5508..2fcacb1 100755
 heap.pl
+++ heap.pl
@@ 37,15 +37,8 @@ sub generate {
# Test for is_odd by seeing if modulo 2 of $i is nonzero. Since we
# check for is_odd vs is_even, we swap the code in the ifelse.
 if ( $i % 2 ) {
 # The swap function was handy but idiomatic Perl allows us to swap
 # variables in place
 ( $A[ $c[$i] ], $A[$i] ) = ( $A[$i], $A[ $c[$i] ] );
 }
 else {
 ( $A[0], $A[$i] ) = ( $A[$i], $A[0] );
 }

+ my $x = $i % 2 ? $c[ $i ] : 0;
+ ( $A[ $x ], $A[$i] ) = ( $A[$i], $A[ $x ] );
output(@A);
# Nitpicky but it's nice to have ++ instead of += 1. Again, not limited
Good catch! Also I looked for an option to enable additional tags and I don't see one. Let me know if you happen to know where Google keeps it.
Post a Comment