Pentominos Solver

My friend has this game called Pentominos. It's a tiling game. You have 11 pieces, all shaped like an L with a peg on the back:

 *
**
 **

You have an 8x8 chessboard. The object is to place all 11 pieces in any flat orientation onto the chessboard. After losing too many hours to the thing, I decided to lose some more, but in a productive way, namely de-rusting some of my perl skills (indeed, I haven't been seen here since Azatoth was my level.)

It took about 3 hours to get the base structure, then 6 hours of optimizations (so it'd run in my lifetime) and (lots of) debugging. I'd love to hear anyone's suggestions for optimizations or improvements.

On an Athlon 900 MHz with 1GB ram, it took about 215 seconds, completing around 2.25 million 'boards'. (you'll notice some of them are optimized away, but still counted, and many aren't counted at all... really, the counting is very subjective).

Here goes:

# Pentominos solver
use strict;
use warnings;
use diagnostics;



#===================================================================
# Constants and global variables
#===================================================================

my $START_TIME = time();

my $SOLVE_COUNT = 0; # counts entrances into the solve() function

my $INDEX_MIN =  1;  # lowest/highest indexed pentomino
my $INDEX_MAX = 11;

my $X_MIN = 1;       # max/min x/y coordinates on @board
my $X_MAX = 6;
my $Y_MIN = 2;
my $Y_MAX = 6;
   
my $O_MIN = 0;       # max and min orientation indicies
my $O_MAX = 7;

#my @pent;  
#for (0..10) { $pent[$_] = {x=>0, y=>0, o=>0}; }

my @board = ( 
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
        [ 0, 0, 0, 0, 0, 0, 0, 0 ] ,
);
 


#
# Orientation reference
# An array of array of hashes
# Each pentomino has a center and occupies 4 extra spaces
#   of the 8 around the center.  The orientations are simply 
#   rotations, then a flip and rotations.
# There are 8 possible orientations, 4 occupies spaces each, 
#   and 2 coordinates for each space

my @orientation = ( 
    [ {x=>-1, y=>-1}, {x=> 0, y=>-1}, {x=> 0, y=>+1}, {x=>+1, y=> 0} ]
+, 
    [ {x=>-1, y=> 0}, {x=>-1, y=>+1}, {x=> 0, y=>-1}, {x=>+1, y=> 0} ]
+,
    [ {x=>-1, y=> 0}, {x=> 0, y=>-1}, {x=> 0, y=>+1}, {x=>+1, y=>+1} ]
+,
    [ {x=>-1, y=> 0}, {x=> 0, y=>+1}, {x=>+1, y=>-1}, {x=>+1, y=> 0} ]
+,
    [ {x=>-1, y=> 0}, {x=> 0, y=>-1}, {x=> 0, y=>+1}, {x=>+1, y=>-1} ]
+,
    [ {x=>-1, y=>-1}, {x=>-1, y=> 0}, {x=> 0, y=>+1}, {x=>+1, y=> 0} ]
+,
    [ {x=>-1, y=>+1}, {x=> 0, y=>-1}, {x=> 0, y=>+1}, {x=>+1, y=> 0} ]
+,
    [ {x=>-1, y=> 0}, {x=> 0, y=>-1}, {x=>+1, y=> 0}, {x=>+1, y=>+1} ]
+,
);



#===================================================================
# next_position_accross ( x coordinate, y coordinate )
#===================================================================
# From the x,y position, figures the next space from left to right
#   or, if at the end of the board, the left most space one line up.
# If we exceed the topmost line, returns invalid coordinates (-1,-1)
#   so the calling program knows to back down the pentomino tree and
#   try again.
#===================================================================
sub next_position_accross {
  my ($x, $y) = @_;
  if ( ++$x > $X_MAX ) { 
  $x = $X_MIN;
    if ( ++$y > $Y_MAX ) { return (-1, -1); }
  }
  return ( $x, $y );
}
    
#===================================================================
# next_position_diag ( x coordiante, y coordinate )
#===================================================================
# Eventually, in the interest of sexiness and efficiency, we might
# impliment a function which tries spaces on diagonals closest to 
# the origin, but for now the accross function will do.
#===================================================================
#sub next_position_diag { }


#===================================================================
# insert_piece ( x coordinate, y coordinate, orientation, number )
#===================================================================
# inserts piece into the @board
# based on the coord and orientation, marks the spaces on the @board
#   with the number of the piece filling each spot
# suggested calling: 
#   insert_piece($pent[$i]{x}, $pent[$i]{y}, $pent[$i]{o}, $i);
#===================================================================
sub insert_piece {
  my ($x, $y, $o, $n) = @_;
  my @or = @{$orientation[$o]};
    $board[$x][$y] = $n;
    for my $i (0..3) {
    $board[$x+$or[$i]{'x'}] [$y+$or[$i]{'y'}] = $n;
  }
}

#===================================================================
# delete_piece ( x coordinate, y coordinate, orientation )
#===================================================================
# deletes piece from the @board
# based on the coord and orientation, empties the spaces on the 
#   @board by marking them as 0.
# suggested calling: 
#   delete_piece($pent[$i]{x}, $pent[$i]{y}, $pent[$i]{o};
#===================================================================
sub delete_piece {
  my ($x, $y, $o) = @_;
  my @or = @{$orientation[$o]};
    $board[$x][$y] = 0;
  for my $i (0..3) {
    $board[$x+$or[$i]{'x'}] [$y+$or[$i]{'y'}] = 0;
  }
}


#===================================================================
# check_position ( x coordinate, y coordinate , orientation )
#===================================================================
# Given coordinates on the @board and an index of previously tried
# orientations, finds the next orientation possible at that spot,
# if any.  If not, returns an orientation of -1, indicating the 
# calling program should try a different spot.
#===================================================================

sub check_position {
  my ($x, $y, $o) = @_;
  if ($board[$x][$y] > 0) { return -1; }

LOOP:  for (; $o <= $O_MAX; $o++) {
    my @or = @{$orientation[$o]};
#    print "x=$x, y=$y, o=$o\n";
    for my $i (0..3) {
#        print ("x'=" . ($or[$i]{'x'}) . " y'=" . ($or[$i]{'y'}) . "\n
+");
      if ($board[$x+$or[$i]{'x'}][$y+$or[$i]{'y'}] > 0) {
        next LOOP;
      }
    }
#        print "through\n";
    return $o;    
  }
  return -1;
}


#===================================================================
# print_board ()
#===================================================================
# Prints the current state of the board
#===================================================================

sub print_board {

  my $t = time();
    my $dif = $t-$START_TIME+1;
    my $rate = $SOLVE_COUNT/$dif;
    print "$dif seconds elapsed.  Rate = $rate.  Count = $SOLVE_COUNT\
+n"; 

    print "  01234567\n  --------\n";
    
  for my $y (0..7) {
        print "$y|";
    for my $x (0..7) { 
            if ($board[$x][$y] == 0) { print '.'; }
            else { printf  ("%x", $board[$x][$y]);  }
        }
    print "|\n";
  }
    
    print "  --------\n";
}


#===================================================================
# exceeds_hole_count ( index )
#===================================================================
# Support for an optimization technique.  We count the holes below
#   and including a certain diagonal (index'th diagonal).  Back in
#   the code, if the number of holes exceeds the index, return true
#   else false.  
# This way, we pack in the pentominos as tightly as possible, and
#   avoid equivalent, rearranged sets.
#===================================================================
sub exceeds_hole_count {
    my $index = shift;
    my $count = 0;
    for my $x (0..7) {
        for my $y (0..7) {
            if (($x+$y) > $index   )  { last     }
            if ($board[$x][$y] == 0)  { $count++ }
            if ($count > $index    )  { return 1 }
        }
    }
    return 0;
}
            


#===================================================================
# solve ( index )
#===================================================================
# Driving function of the program, recursive
#===================================================================
sub solve {

    if (!($SOLVE_COUNT % 1000)) { print_board(); }
  
    my $index = shift;
  
    my $x; if ($index > $X_MAX) {$x=$X_MAX;} else { $x = $index;}
#    my $x = $X_MIN;
  my $y = $Y_MIN;
    $SOLVE_COUNT+=$x;

  while (1) {
    my $o = $O_MIN;
      while (($o = check_position ( $x, $y, $o)) <= $O_MAX) {
#            print "I=$index, O=$o\n";
      if ($o >= 0) { 

                insert_piece ( $x, $y, $o, $index );

#        print_board if $index >= 10;
                
                if ( $index >= $INDEX_MAX ) {
          print "Success!\n\n";
          print_board();
          exit();
        } 
        # If piece is efficiently placed, try the next pentomino
        #   (tend to cluster them towards origin)
            if (!exceeds_hole_count($index)) { solve ($index+1); }

                delete_piece ( $x, $y, $o );
            $o++
            } else {
        last;
            }
        }
        while (1) {

            ($x, $y) = next_position_accross ( $x, $y ); 
#      print "i=$index, x=$x, y=$y\n";
      # if the pentomino has run off the board, we need to backup
      #   and try again.
            if ($x < 0) { return } 

            $SOLVE_COUNT++;    

      # Start the piece well out onto the board 
            if (($x+$y) < $index)     { 
#                print 's'; 
                next 
            };
            
      # Optimization by which piece never starts too far out on board.
      if (($x+$y) > (2*$index)) { print 'b'; next };
      if ($y > $index)            { print 'y'; return };
            
            last;
        }
  }

}
      
solve($INDEX_MIN);

print "FAILIURE!\n";
print "COUNT = $SOLVE_COUNT\n";
print_board();
[download]

For those of you just dying to know the answer...

  01234567
  --------
0|.122..4.|
1|11122444|
2|13326684|
3|33566888|
4|.3556aa8|
5|7559aab.|
6|77799abb|
7|.799.bb.|
  --------

Lexicon

Edited: ~Mon Sep 9 16:14:35 2002 (GMT) by footpad: Added <readmore> tag, per Consideration.

Back to Cool Uses for Perl