Games::Pentominos - solving the pentominos paving puzzle

  use Games::Pentominos;

  my $board = "xxxxxxxxxx\n" x 6;
  my $solution_printer = sub {
   my ($placed, $n_solutions, $t_solution, $t_tot) = @_;
   printf "Solution %d\n%s\n", $n_solutions, $placed;
   return 1; # continue searching
  }

  Games::Pentominos->solve($board, $solution_printer);

  Games::Pentominos->solve($board, $solution_callback);

  xxxx....xxxx
  xxxx....xxxx
  xxxx....xxxx
  xxxxxxxxxxxx
  xxxxxxxxxxxx
  xxxxxxxxxxxx

  $should_continue = $callback->($placed, $n_solutions, $t_solution, $t_tot);

#======================================================================
package Games::Pentominos; # see doc at end of file
#======================================================================
our $VERSION = "1.0";
use strict;
use warnings;
use Time::HiRes     qw/time/;
use List::MoreUtils qw/uniq/;

# work mostly with global vars because this is fastest than parameter-passing
our    # because accessed from eval
   $board;             # cells remaining to be filled 
my $placed;            # cells filled so far
my $print_solution;    # callback for printing a solution
my ($t_ini, $t_tot);   # times in milliseconds
my $n_solutions;       # how many solutions found
my %substitutions;     # a coderef for each pentomino/permutation

# description of the 12 pentominos. Each of them has a labelling letter,
# a number of permutations, and for each permutation a rectangle describing
# the pentomino shape. Occupied cells are shown with an 'x', untouched cells
# with a '.' (this character explicitly chosen so that in regexes it will
# match anything except a newline character).

my %pentominos = (
  F => [8, qw/.xx xx. x.. ..x .x. .x. .x. .x.
              xx. .xx xxx xxx xxx xxx xx. .xx
              .x. .x. .x. .x. x.. ..x .xx xx./],

  I => [2, qw/xxxxx x
              ..... x
              ..... x
              ..... x
              ..... x/],

  L => [4, qw/xxxx xxxx x. .x
              x... ...x x. .x
              .... .... x. .x
              .... .... xx xx/],

  P => [8, qw/xx xx xxx xxx x. .x xx. .xx
              xx xx xx. .xx xx xx xxx xxx
              x. .x ... ... xx xx ... .../],

  S => [8, qw/xx.. ..xx xxx. .xxx x. .x x. .x
              .xxx xxx. ..xx xx.. xx xx x. .x
              .... .... .... .... .x x. xx xx
              .... .... .... .... .x x. .x x./],

  T => [4, qw/xxx .x. x.. ..x
              .x. .x. xxx xxx
              .x. xxx x.. ..x/],

  U => [4, qw/xxx x.x xx xx
              x.x xxx x. .x
              ... ... xx xx/],

  V => [4, qw/xxx xxx x.. ..x
              x.. ..x x.. ..x
              x.. ..x xxx xxx/],

  W => [4, qw/xx. .xx x.. ..x
              .xx xx. xx. .xx
              ..x x.. .xx xx./],

  X => [1, qw/.x.
              xxx
              .x./],

  Y => [8, qw/.x x. .x x. xxxx xxxx ..x. .x..
              xx xx .x x. .x.. ..x. xxxx xxxx
              .x x. xx xx .... .... .... ....
              .x x. .x x. .... .... .... ..../],

  Z => [4, qw/xx. .xx x.. ..x
              .x. .x. xxx xxx
              .xx xx. ..x x../],
);



#----------------------------------------------------------------------
sub solve {
#----------------------------------------------------------------------
  my ($self, $submitted_board, $submitted_callback) = @_;

  # initialize globals
  ($board, $placed) = ($submitted_board, "");
  $print_solution   = $submitted_callback;

  # check if $board meets requirements
  my $n_cells = ($board =~ tr/x//);
  my ($board_n_cols, @others) = uniq map length, ($board =~ m/.+/g);
  $n_cells == 60   or die "board does not have 60 empty cells noted as 'x'";
  not @others      or die "board has rows of different lengths";

  # check if callback is a coderef
  ref $print_solution eq 'CODE' or die "improper callback for solutions";

  # compile the substitution subroutines
  _compile_substitutions($board_n_cols);

  # anything up to first free cell goes to "placed"
  $board =~ s/^([^x]+)// and $placed .= $1;

  # start computing solutions
  $t_ini       = time;
  $t_tot       = 0;
  $n_solutions = 0;
  _place_pentomino(keys %pentominos);
}



#----------------------------------------------------------------------
sub _compile_substitutions {
#----------------------------------------------------------------------
  my ($board_n_cols) = @_; # how many columns in each row

  %substitutions = ();
  while (my ($letter, $array_ref) = each %pentominos) {

    my $n_permutations = $array_ref->[0]; # how many possible layouts 
    my $n_rows         = (@$array_ref-1) / $n_permutations;

    for my $perm_id (0 .. $n_permutations-1) {

      # gather data rows for that permutation
      my @rows      = map {$array_ref->[$_ * $n_permutations + $perm_id + 1]}
                          (0..$n_rows-1);
      my $n_cols    = length ($rows[0]);

      # construct regex to match that permutation
      # NOTE: \D below is just a convenience for char class [FILPSTUVWXYZx.\n]
      my $skip_to_next_row = sprintf "\\D{%d}", $board_n_cols + 1 - $n_cols;
      my $regex            = join $skip_to_next_row, @rows;

      # remove everything before or after the touched cells
      $regex =~ s/^[^x]+//;
      $regex =~ s/[^x]+$//;

      # add capture brackets in regex
      $regex =~ s/([^x]+)/($1)/g;

      # substitution string : replace 'x' by letter 
      #                       and brackets by captured groups
      (my $subst = $regex) =~ s/x/$letter/g;
      my $num_paren = 1;
      $subst =~ s/\(.*?\)/'$'.$num_paren++/eg; 

      # compile a sub performing the substitution 
      push @{$substitutions{$letter}}, 
        eval qq{sub {\$board =~ s/^$regex/$subst/}};
    }
  }
}


#----------------------------------------------------------------------
sub _place_pentomino { # the recursive algorithm
#----------------------------------------------------------------------
  # my @letters = @_; # commented out for speed (avoiding copy)

  my ($board_ini, $placed_ini) = ($board, $placed);

  foreach my $letter (@_) {
    foreach my $substitution (@{$substitutions{$letter}}) {
      if ($substitution->()) { # try to apply this pentomino to $board

        # anything up to next free cell goes to "placed"
        $board =~ s/^([^x]+)// and $placed .= $1;

        if (!$board) { # no more free cells, so this is a solution
          my $t_solution = time - $t_ini;
          $t_tot       += $t_solution;
          $n_solutions += 1;
          $print_solution->($placed, $n_solutions, $t_solution, $t_tot)
            or return; # stop searching if callback did not return true
          $t_ini = time;
        }
        else {
          _place_pentomino(grep {$_ ne $letter} @_)
            or return; 
        }

        # restore to previous state (remove pentomino from board)
        ($board, $placed) = ($board_ini, $placed_ini);
      }
    }
  }
  return 1; # continue searching
}


__END__