Perl:Golf

From Carls wiki

Jump to: navigation, search

This is a step-by-step tutorial of how to golf down a Perl program.

Our starting material is this: 

use strict;

# The classical 8 queens puzzle
# Place 8 queens on a chess board without any of them threatening each other

# Returns true if the first argument equals any of the subsequent ones,
# otherwise returns false
sub any_equals {
   my $value = shift;

   while (my $other_value = shift) {
       return 1 if $value == $other_value;
   }

   return '';
}

# Returns true if the first argument differs (absolutely) by one from the
# second, or by two from the third, or... and so on, otherwise returns
# false
sub any_aligns {
   my $value = shift;
   my $difference = 0;

   while (my $other_value = shift) {
       ++$difference;
       return 1 if abs($value - $other_value) == $difference;
   }

   return '';
}

sub generate_solutions {
   my $levels_left = shift;
   my @values_so_far = @_;

   for my $column (1..8) {
       next if any_equals($column, @values_so_far);
       next if any_aligns($column, @values_so_far);

       if ($levels_left > 1) {
           generate_solutions($levels_left - 1, $column, @values_so_far);
       }
       else {
           print join ' ', ($column, @values_so_far);
           print "\\n";
       }
   }
}

generate_solutions(8);


Contents

Explanation of the algorithm

First, we'll briefly go through how the algorithm works. While not essential for the task, it might be of interest to know what it is we are golfing down. If you have problems like this for breakfast, or if you love Perl golfing but your eyes glaze over at the explanation of algorithms, you are free to skip this part.

M MM M M M M M

One of the solutions to the eight queens puzzle. Reading the text to the right, while also looking at the board, will serve as a help if you wish to become cross-eyed.
The eight queens puzzle consists of placing eight queens on an 8x8 chess board in such a way that no queen threatens another. That means that no two queens can stand on the same row, column, or diagonal.

The above algorithm makes use of the fact that we must have exactly one queen on each row. The column number of each queen then becomes a free variable. These eight variables are then subject to two constraints, and each set of eight variables that fulfills the constraints, is a solution to the puzzle. There are 92 such solutions.

The two constraints are:

Different columns
No two free variables may have the same value, since that would place two queens on the same column.
Different diagonals
No two free variables may have a difference equal to the difference in their indices. For example, the third and fifth variable may not differ by a value of two, since this would mean that two queens (in this case, the one on row three and the one on row five) diagonally threatened each other.

No constraint is needed for different rows, since that is built into the assumptions of the data structure.

M MM M m m

Midway through the search for solutions. The black queens indicate the choices we can make at this point, according to our constraints.
Two further insights help the understanding of the algorithm: first, we can — without loss of generality — decide the values of the free variables in order, as long as we try every solution along the way. On the board, this is represented by choosing the locations of the queens row by row, top-down. We need only check the constraints between a new possible value and the values of the already fixed variables (that is, the queens above the current row). The second board on the right illustrates this; on the fifth row we can choose to place a queen either in column 2 or in column 7. The value 2 is a dead end; only choosing the value 7 will lead to a solution, namely the one on the board above.

Second, instead of writing eight nested for loops, one for each row — a fairly tedious solution, not to mention that it doesn't scale well if we ever decide to solve the 18-queens puzzle — we can use recursion, making a new call for each free variable we want to fix. The base case of the recursion is when all eight variables are fixed and we have found a solution. The mechanisms of recursion will help keep track of which parts of the solution space we haven't visited yet.

Now, let's golf.

Comments

Comments are the first up against the wall when golfing. 

use strict;

# The classical 8 queens problem
# Place 8 queens on a chess board without any of them threatening each other


# Returns true if the first argument equals any of the subsequent ones,
# otherwise returns false
sub any_equals {
   my $value = shift;

   while (my $other_value = shift) {
       return 1 if $value == $other_value;
   }

   return '';
}

# Returns true if the first argument differs (absolutely) by one from the
# second, or by two from the third, or... and so on, otherwise returns
# false
sub any_aligns {
   my $value = shift;
   my $difference = 0;

   while (my $other_value = shift) {
       ++$difference;
       return 1 if abs($value - $other_value) == $difference;
   }

   return '';
}

sub generate_solutions {
   my $levels_left = shift;
   my @values_so_far = @_;

   for my $column (1..8) {
       next if any_equals($column, @values_so_far);
       next if any_aligns($column, @values_so_far);

       if ($levels_left > 1) {
           generate_solutions($levels_left - 1, $column, @values_so_far);
       }
       else {
           print join ' ', ($column, @values_so_far);
           print "\\n";
       }
   }
}

generate_solutions(8);



use strict;

sub any_equals {
   my $value = shift;

   while (my $other_value = shift) {
       return 1 if $value == $other_value;
   }

   return '';
}

sub any_aligns {
   my $value = shift;
   my $difference = 0;

   while (my $other_value = shift) {
       ++$difference;
       return 1 if abs($value - $other_value) == $difference;
   }

   return '';
}

sub generate_solutions {
   my $levels_left = shift;
   my @values_so_far = @_;

   for my $column (1..8) {
       next if any_equals($column, @values_so_far);
       next if any_aligns($column, @values_so_far);

       if ($levels_left > 1) {
           generate_solutions($levels_left - 1, $column, @values_so_far);
       }
       else {
           print join ' ', ($column, @values_so_far);
           print "\\n";
       }
   }
}

generate_solutions(8);


Variables and subroutines

There's no good reason to make the names of variables and subroutines longer than one character each. The variable @values_so_far goes away entirely, because we might as well keep things in @_. 

use strict;

sub any_equals {
   my $value = shift;

   while (my $other_value = shift) {
       return 1 if $value == $other_value;
   }

   return '';
}

sub any_aligns {
   my $value = shift;
   my $difference = 0;

   while (my $other_value = shift) {
       ++$difference;
       return 1 if abs($value - $other_value) == $difference;
   }

   return '';
}

sub generate_solutions {
   my $levels_left = shift;
   my @values_so_far = @_;

   for my $column (1..8) {
       next if any_equals($column, @values_so_far);
       next if any_aligns($column, @values_so_far);

       if ($levels_left > 1) {
           generate_solutions($levels_left - 1, $column, @values_so_far);
       }
       else {
           print join ' ', ($column, @values_so_far);
           print "\\n";
       }
   }
}

generate_solutions(8);



use strict;

sub e {
   my $v = shift;

   while (my $o = shift) {
       return 1 if $v == $o;
   }

   return '';
}

sub a {
   my $v = shift;
   my $d = 0;

   while (my $o = shift) {
       ++$d;
       return 1 if abs($v - $o) == $d;
   }

   return '';
}

sub g {
   my $l = shift;

   for my $c (1..8) {
       next if e($c, @_);
       next if a($c, @_);

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print join ' ', ($c, @_);
           print "\\n";
       }
   }
}

g(8);


Replace while loops with grep

Both while loops return a positive value upon finding something in a list. We can use grep for that. The loop variable $o goes away, being replaced by $_. 

use strict;

sub e {
   my $v = shift;

   while (my $o = shift) {
       return 1 if $v == $o;
   }

   return '';
}

sub a {
   my $v = shift;
   my $d = 0;

   while (my $o = shift) {
       ++$d;
       return 1 if abs($v - $o) == $d;
   }

   return '';
}

sub g {
   my $l = shift;

   for my $c (1..8) {
       next if e($c, @_);
       next if a($c, @_);

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print join ' ', ($c, @_);
           print "\\n";
       }
   }
}

g(8);



use strict;

sub e {
   my $v = shift;

   return grep $v == $_, @_;
}

sub a {
   my $v = shift;
   my $d = 0;

   return grep abs($v - $_) == ++$d, @_;
}

sub g {
   my $l = shift;

   for my $c (1..8) {
       next if e($c, @_);
       next if a($c, @_);

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print join ' ', ($c, @_);
           print "\\n";
       }
   }
}

g(8);


Inline subs

Now we are in a position where we can eliminate the subroutine calls and inline the grep expressions. 

use strict;

sub e {
   my $v = shift;

   return grep $v == $_, @_;
}

sub a {
   my $v = shift;
   my $d = 0;

   return grep abs($v - $_) == ++$d, @_;
}

sub g {
   my $l = shift;

   for my $c (1..8) {
       next if e($c, @_);
       next if a($c, @_);

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print join ' ', ($c, @_);
           print "\\n";
       }
   }
}

g(8);



use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       next if grep $c == $_, @_;
       my $d = 0;
       next if grep abs($c - $_) == ++$d, @_;

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print join ' ', ($c, @_);
           print "\\n";
       }
   }
}

g(8);


Combine two greps into one

In fact, why keep two grep expressions around, running over the same list, when we can make do with one?

While we're at it, we'll combine the two print statements into one. 

use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       next if grep $c == $_, @_;
       my $d = 0;
       next if grep abs($c - $_) == ++$d, @_;

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print join ' ', ($c, @_);
           print "\\n";
       }
   }
}

g(8);



use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       next if grep abs($c - $_) == ++$d || $c == $_, @_;

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print ((join ' ', ($c, @_)), "\\n");
       }
   }
}

g(8);


Favor logical connectives to control flow

If we could somehow write the the two if statements as a string of ands and ors, that would sure help a lot.

Note that the return value of g suddenly becomes important, which means that we will have to invert the (false) value that is returned from the recursive call. If we don't, control will proceed to the print statement even when a solution hasn't been found. 

use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       next if grep abs($c - $_) == ++$d || $c == $_, @_;

       if ($l > 1) {
           g($l - 1, $c, @_);
       }
       else {
           print ((join ' ', ($c, @_)), "\\n");
       }
   }
}

g(8);



use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs($c - $_) == ++$d || $c == $_, @_

           or

       ( $l > 1 and
           !g($l - 1, $c, @_) )

           or

       print ((join ' ', ($c, @_)), "\\n");
   }
}

g(8);


Change the domain of $l

The variable $l (formerly known as $levels_left) counts down from 8 to 1 in the course of the recursion. The exact numbers $l takes on is unimportant; all it needs to do is range over eight distinct values. We are wasting three precious characters just to call g with the value 8 as a parameter. Let's have $l range from 0 to 7 instead. 

use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs($c - $_) == ++$d || $c == $_, @_

           or

       ( $l > 1 and
           !g($l - 1, $c, @_) )

           or

       print ((join ' ', ($c, @_)), "\\n");
   }
}

g(8);



use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs($c - $_) == ++$d || $c == $_, @_

           or

       ( $l < 7 and
           !g($l + 1, $c, @_) )

           or

       print ((join ' ', ($c, @_)), "\\n");
   }
}

g;


More logic (or lack of it)

Instead of writing and, we can use &&, bitwise or. This operator has higher priority than or, so we can ditch the parentheses. Hm, let's ditch the superfluous parentheses in the abs call while we're at it.

In fact, let's not use &&, let's use & instead. It works just as well in cases where short-circuiting is not important. (How can short-circuiting not be important in the case of a conditionally executed recursive call? Won't we get an infinite regress if we don't short-circuit in this case? As it turns out, we do recurse one level deeper than we need, but the recursion stops there, since nine values will never fulfill the constraints and thus the grep will return control immediately. Surely making that extra trip is worth it for saving one more character.)

We'll replace || in the grep expression with | too. This works because | binds looser than ==.

Also, we'll change our second or to || so that we can eliminate more whitespace later. 

use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs($c - $_) == ++$d || $c == $_, @_

           or

       ( $l < 7 and
           !g($l + 1, $c, @_) )

           or

       print ((join ' ', ($c, @_)), "\\n");
   }
}

g;



use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs $c - $_ == ++$d | $c == $_, @_

           or

       $l < 7 &
           !g($l + 1, $c, @_)

           ||

       print ((join ' ', ($c, @_)), "\\n");
   }
}

g;


The Babycart operator

There are shorter ways to separate list elements by whitespace, as this thread shows. We don't need the final semicolon in the print statement either. That goes for the semicolon at the end of the program, too. 

use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs $c - $_ == ++$d | $c == $_, @_

           or

       $l < 7 &
           !g($l + 1, $c, @_)

           ||

       print ((join ' ', ($c, @_)), "\\n");
   }
}

g;



use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs $c - $_ == ++$d | $c == $_, @_

           or

       $l < 7 &
           !g($l + 1, $c, @_)

           ||

       print "@{[$c,@_]}\\n"
   }
}

g


Replace shift with pop

By passing $l as the last argument to g instead of the first, we can use pop instead of shift. 

use strict;

sub g {
   my $l = shift;

   for my $c (1..8) {
       my $d = 0;
       grep abs $c - $_ == ++$d | $c == $_, @_

           or

       $l < 7 &
           !g($l + 1, $c, @_)

           ||

       print "@{[$c,@_]}\\n"
   }
}

g



use strict;

sub g {
   my $l = pop;

   for my $c (1..8) {
       my $d = 0;
       grep abs $c - $_ == ++$d | $c == $_, @_

           or

       $l < 7 &
           !g($c, @_, $l + 1)

           ||

       print "@{[$c,@_]}\\n"
   }
}

g


Not so strict anymore, eh?

Believe it or not, the code as it stands is still perfectly valid strict Perl. But in order to squeeze the last few characters out of the code, we remove the use strict; line in the beginning. This lets us avoid using my before $c.

Note that we cannot remove the my before $l, since we need this variable to be restored when returning from recursive calls, and thus it cannot be global. With $d, we need to initialize it to zero somehow before the grep, and we can do this with either the my keyword or with an assignment. Since both these have the same length (two characters), it doesn't matter for the golfing which one we choose. We'll go with my, since it needfully restores the letters/punctuation balance a little.

Finally, we reverse the order of the left and right hand sides in the first equality test in the grep expression, so that we can save an extra space by writing things together in the next step. 

use strict;

sub g {
   my $l = pop;

   for my $c (1..8) {
       my $d = 0;
       grep abs $c - $_ == ++$d | $c == $_, @_

           or

       $l < 7 &
           !g($c, @_, $l + 1)

           ||

       print "@{[$c,@_]}\\n"
   }
}

g



sub g {
   my $l = pop;

   for $c (1..8) {
       my $d;
       grep ++$d == abs $c - $_ | $c == $_, @_

           or

       $l < 7 &
           !g($c, @_, $l + 1)

           ||

       print "@{[$c,@_]}\\n"
   }
}

g


Whitespace

Finally, we'll throw out all the wasteful spaces and newlines, keeping only two that we actually need: one between sub and g, and one just before the or. 

sub g{my$l=pop;for$c(1..8){my$d;grep++$d==abs$c-$_|$c==$_,@_
or$l<7&!g($c,@_,$l+1)||print "@{[$c,@_]}\\n"}}g

Ah, brevity.

Retrieved from "http://masak.org/carl/w/index.php/Perl:Golf"