Tuesday, December 13, 2016

Heap's Algorithm and Generating Perl Code From Pseudocode

I've been researching recursion lately and in particular, permutations algorithms. This interest was spurred by a real-life 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 non-recursive 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:

1. sub output {
2. my (@to_print) = @_;
3. print join( ',', @to_print ), "\n";
4. }
5. sub is_even {
6. return \$_ % 2 ? 0 : 1;
7. }
8. # By referring to \$_ and \$_ instead of assigning their values to other
9. # variables, we can force pass-by-reference here so that the change will
10. # impact @A directly even though we are in a separate function outside its
11. # scope.
12. sub swap {
13. (\$_,\$_) = (\$_,\$_);
14. }
15. sub generate {
16. my (\$n, @A) = @_;
17. my @c;
18. for ( my \$i = 0; \$i < \$n; \$i += 1 ) {
19. \$c[\$i] = 0;
20. }
21. output(@A);
22. my \$i = 0;
23. while ( \$i < \$n ) {
24. if ( \$c[\$i] < \$i ) {
25. if ( is_even(\$i) ) {
26. swap( \$A, \$A[\$i] );
27. }
28. else {
29. swap( \$A[ \$c[\$i] ], \$A[\$i] );
30. }
31. output(@A);
32. \$c[\$i] += 1;
33. \$i = 0;
34. }
35. else {
36. \$c[\$i] = 0;
37. \$i += 1;
38. } # end if
39. } # end while
40. }
41. 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:

1. sub output {
2. print join( ',', @_ ), "\n";
3. }
4. sub generate {
5. # We don't need to pass n here because we have @A. That's not at all
6. # unique to Perl of course but the cool part comes later...
7. my (@A) = @_;
8. # I don't need to specify the length of array @c because as soon as we
9. # refer to an element, it exists. I don't need to initialize @c or \$i
10. # because as soon as we start performing math on their values they will be
11. # assumed to start at zero.
12. my (@c,\$i);
13. output(@A);
14. # The cool part: we can refer to the length of the @A array as simply @A
15. # in scalar context.
16. while ( \$i < @A ) {
17. if ( \$c[\$i] < \$i ) {
18. # Test for is_odd by seeing if modulo 2 of \$i is non-zero.
19. # Since we check for is_odd vs is_even, we swap the code in the
20. # if-else.
21. if ( \$i % 2 ) {
22. # The swap function was handy but idiomatic Perl allows us to
23. # swap variables in place
24. ( \$A[ \$c[\$i] ], \$A[\$i] ) = ( \$A[\$i], \$A[ \$c[\$i] ] );
25. }
26. else {
27. ( \$A, \$A[\$i] ) = ( \$A[\$i], \$A );
28. }
29. output(@A);
30. # Nitpicky but it's nice to have ++ instead of += 1. Again, not
31. # limited to Perl.
32. \$c[\$i]++;
33. \$i = 0;
34. }
35. else {
36. \$c[\$i] = 0;
37. \$i++;
38. }
39. }
40. }
41. 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:

1. sub output {
2. print join( ',', @_ ), "\n";
3. }
4. sub generate {
5. my (@A) = @_;
6. output(@A);
7. while ( \$i < @A ) {
8. if ( \$c[\$i] < \$i ) {
9. my \$x = \$i % 2 ? \$c[ \$i ] : 0;
10. ( \$A[ \$x ], \$A[\$i] ) = ( \$A[\$i], \$A[ \$x ] );
11. output(@A);
12. \$c[\$i]++;
13. \$i = 0;
14. }
15. else {
16. \$c[\$i] = 0;
17. \$i++;
18. }
19. }
20. }
21. generate( split '', 'abcd' );

Monday, September 26, 2016

Tattletale Variables

Sometimes you might be faced with a huge program that, somewhere, is changing a variable's value to something undesired.

1. use Data::Dumper;
2. sub some_long_faraway_function {
3. my \$href = shift;
4. # Pretend there's a lot of code here I don't want to sift through
5. \$href->{bananas} = 'some bad value';
6. }
7. my \$shopping_list = {
8. apples => 1,
9. pears => 3,
10. bananas => 5,
11. };
12. some_long_faraway_function(\$shopping_list);
13. warn Dumper(\\$shopping_list);

Output:

\$VAR1 = \{
'apples' => 1,
'pears' => 3
};

You don't know where it's being changed, but you need to find out. Change the variable so that it tells you where it's being changed.

1. package TattletaleScalar;
2. use Carp qw(cluck);
3. require Tie::Scalar;
4. our @ISA = qw(Tie::StdScalar);
5. sub STORE {
6. warn "TATTLETALE variable set to {\$_}";
7. cluck();
8. \${\$_} = \$_;
9. }
10. package main;
11. use Data::Dumper;
12. sub some_long_faraway_function {
13. my \$href = shift;
14. # Pretend there's a lot of code here I don't want to sift through
15. \$href->{bananas} = 'some bad value';
16. }
17. my \$shopping_list = {
18. apples => 1,
19. pears => 3,
20. bananas => 5,
21. };
22. my \$tmp = \$shopping_list->{bananas}; # Save current value
23. tie \$shopping_list->{bananas}, 'TattletaleScalar';
24. \$shopping_list->{bananas} = \$tmp; # Restore saved value
25. some_long_faraway_function(\$shopping_list);
26. warn Dumper(\\$shopping_list);

Now we can see the stack every time the variable is changed:

TATTLETALE variable set to {5} at example.pl line 7.
at example.pl line 8.
TattletaleScalar::STORE(TattletaleScalar=SCALAR(0x7fac290d3260), 5) called at example.pl line 29
TATTLETALE variable set to {some bad value} at example.pl line 7.
at example.pl line 8.
TattletaleScalar::STORE(TattletaleScalar=SCALAR(0x7fac290d3260), "some bad value") called at example.pl line 19
main::some_long_faraway_function(HASH(0x7fac29026508)) called at example.pl line 30
\$VAR1 = \{
'apples' => 1,
'pears' => 3,