Here is my solution. I didn't really make any effort to optimize it (I confess I got a bit lazy and used a few globals), and I'm sure there are some scary parts. If anyone spots something truly evil, please let me know so I can avoid using that construct in the future. I tried to make my code a bit generic so I could apply it to other puzzles as well.
According to this code, there are 2 solutions, each 112 moves in length (where 1 move is defined as moving 1 block exactly one square). Of course, there are many other solutions possible that use more than 112 moves. I am very pleased that the number of steps (112) agrees with previous solutions!
Update: It seems I introduced a bug when I created some subroutines before I posted it. Darn off-by-1 errors! ;) I fixed the problem, and the updated code is below. It's a little ugly, but it works.
use strict;
use warnings;
open( OUTFILE, ">results.txt" ) or die "error opening output file";
# grid dimensions (max coord allowed) (used as globals so don't have t
+o pass around)
# note: this is not the number of cells in the grid, but the max coord
+ (array index, starts at 0)
my $GRID_X_MAX = 3;
my $GRID_Y_MAX = 4;
# set up starting grid, winning condition, and block definitions
# each block has a unique letter, holes are 0
my @start_grid = qw(
ABBC
ABBC
0DD0
EFGH
EIJH
);
my %win = ( block => 'B', x => 1, y => 3 ); # upper left corner of blo
+ck in winning position
my %blocks = ( A => 'b',
B => 'd',
C => 'b',
D => 'c',
E => 'b',
F => 'a',
G => 'a',
H => 'b',
I => 'a',
J => 'a',
);
my %blocktypes = ( a => { xsize => 1, ysize => 1 },
b => { xsize => 1, ysize => 2 },
c => { xsize => 2, ysize => 1 },
d => { xsize => 2, ysize => 2 },
);
# xmove and ymove are used to adjust the coords
# directions: up = u, down = d, left = l, right = r
my %movemts = ( u => { undo => 'd', xmove => 0, ymove => -1 },
d => { undo => 'u', xmove => 0, ymove => 1 },
l => { undo => 'r', xmove => -1, ymove => 0 },
r => { undo => 'l', xmove => 1, ymove => 0 } );
my @current_options = ( [ 'start', @start_grid ] );
my ( %seen_grid, @winners );
while( scalar @winners == 0 )
{
print "testing ", scalar @current_options, " options, ";
my @next_options;
foreach my $option ( @current_options )
{
my ( $path, @grid ) = @{ $option };
my @next_moves = find_next_moves( \@winners, $path, @grid );
foreach my $move ( @next_moves )
{
my $dir = shift @{ $move };
my $gridkey = join( '', @{ $move } );
# genericize the block pattern for uniqueness
$gridkey =~ tr/ABCDEFGHIJ/bdbcbaabaa/; # this could be bui
+lt from %blocks
if( not exists $seen_grid{$gridkey} )
{
push( @next_options, [ join( '-', $path, $dir ), @{ $m
+ove } ] );
$seen_grid{$gridkey}++;
}
}
}
print "found ", scalar @next_options, " options\n";
@current_options = @next_options;
}
foreach my $option ( @winners )
{
my $path = shift @{ $option };
print OUTFILE "$path\n";
print OUTFILE ' ', join( "\n ", @{ $option } ), "\n";
}
close OUTFILE;
sub find_next_moves
{
my ( $ref2winners, $path, @grid ) = @_;
my $last = substr( $path, -2 );
# create @orig_grid: $orig_grid[$y][$x] = $block
# identify holes: [ $x, $y ], [...], ...
# %blockpos: find the upper left corner of each block
my ( @orig_grid, @holes, %blockpos );
process_grid( \@orig_grid, \@holes, \%blockpos, @grid );
# find blocks next to holes, store the dir they can move to fill t
+he hole
my %possible_blocks = find_blocks_to_move( \@orig_grid, \@holes );
# make sure the possible moves are valid (they don't overlap with
+another block)
my @new_opts = ();
my ( $lastblock, $lastdir ) = split( '', $last );
foreach my $block ( keys %possible_blocks )
{
my @moves = split( '', $possible_blocks{$block} );
MOVE:
foreach my $move ( @moves )
{
if( $block eq $lastblock and $movemts{$move}{undo} eq $las
+tdir )
{
next MOVE; # skip if undos last move
}
my ( $ref2newgrid, @new_grid_string ) = calc_new_grid( $bl
+ock, $move, \@orig_grid );
if( not defined $ref2newgrid )
{
next MOVE;
}
my $blockmove = join( '', $block, $move );
push( @new_opts, [ $blockmove, @new_grid_string ] );
if( grid_is_winner( $ref2newgrid ) )
{
push( @{ $ref2winners }, [ join( '-', $path, $blockmov
+e ), @new_grid_string ] );
}
}
}
return ( @new_opts );
}
sub process_grid
{
my ( $ref2grid, $ref2holes, $ref2blockpos, @grid ) = @_;
for( my $y = 0; $y <= $GRID_Y_MAX; $y++ )
{
@{ ${ $ref2grid }[$y] } = split( '', $grid[$y] );
for( my $x = 0; $x <= $GRID_X_MAX; $x++ )
{
if( ${ $ref2grid }[$y][$x] eq 0 )
{
push( @{ $ref2holes }, [ $x, $y ] );
}
elsif( not defined ${ $ref2blockpos }{ ${ $ref2grid }[$y][
+$x] } )
{
${ $ref2blockpos }{ ${ $ref2grid }[$y][$x] }{x} = $x;
${ $ref2blockpos }{ ${ $ref2grid }[$y][$x] }{y} = $y;
}
}
}
}
sub find_blocks_to_move
{
my ( $ref2orig_grid, $ref2holes ) = @_;
my %blocks;
foreach my $hole ( @{ $ref2holes } )
{
my ( $hole_x, $hole_y ) = @{ $hole };
if( $hole_x > 0 and ${ $ref2orig_grid }[ $hole_y ][ $hole_x -
+1 ] ne 0 )
{
$blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x - 1 ] } =
( $blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x - 1
+ ] } || '' ) . 'r';
}
if( $hole_x < $GRID_X_MAX and ${ $ref2orig_grid }[ $hole_y ][
+$hole_x + 1 ] ne 0 )
{
$blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x + 1 ] } =
( $blocks{ ${ $ref2orig_grid }[ $hole_y ][ $hole_x + 1
+ ] } || '' ) . 'l';
}
if( $hole_y > 0 and ${ $ref2orig_grid }[ $hole_y - 1 ][ $hole_
+x ] ne 0 )
{
$blocks{ ${ $ref2orig_grid }[ $hole_y - 1 ][ $hole_x ] } =
( $blocks{ ${ $ref2orig_grid }[ $hole_y - 1 ][ $hole_x
+ ] } || '' ) . 'd';
}
if( $hole_y < $GRID_Y_MAX and ${ $ref2orig_grid }[ $hole_y + 1
+ ][ $hole_x ] ne 0 )
{
$blocks{ ${ $ref2orig_grid }[ $hole_y + 1 ][ $hole_x ] } =
( $blocks{ ${ $ref2orig_grid }[ $hole_y + 1 ][ $hole_x
+ ] } || '' ) . 'u';
}
}
return( %blocks );
}
sub calc_new_grid
{
my ( $block, $move, $ref2orig_grid ) = @_;
my @new_grid = map { [ @{ $_ } ] } @{ $ref2orig_grid };
# find the position of $block
my ( $orig_x, $orig_y );
for( my $y = 0; $y <= $GRID_Y_MAX; $y++ )
{
for( my $x = 0; $x <= $GRID_X_MAX; $x++ )
{
if( ${ $ref2orig_grid }[$y][$x] eq $block )
{
( $orig_x, $orig_y ) = ( $x, $y );
( $x, $y ) = ( $GRID_X_MAX + 1, $GRID_Y_MAX + 1 ); # q
+uit the loop
}
}
}
my $new_x = $orig_x + $movemts{$move}{xmove};
my $new_y = $orig_y + $movemts{$move}{ymove};
# delete the old positions for this block
for( my $x = 1; $x <= $blocktypes{ $blocks{$block} }{xsize}; $x++
+)
{
for( my $y = 1; $y <= $blocktypes{ $blocks{$block} }{ysize}; $
+y++ )
{
$new_grid[ $orig_y + $y - 1 ][ $orig_x + $x - 1 ] = 0;
}
}
for( my $x = 1; $x <= $blocktypes{ $blocks{$block} }{xsize}; $x++
+)
{
for( my $y = 1; $y <= $blocktypes{ $blocks{$block} }{ysize}; $
+y++ )
{
if( $new_grid[ $new_y + $y - 1 ][ $new_x + $x - 1 ] ne 0 )
{
return; # skip if moving this block would overlap anot
+her block
}
else
{
$new_grid[ $new_y + $y - 1 ][ $new_x + $x - 1 ] = $blo
+ck;
}
}
}
my @new_grid_string = map { join( '', @{ $_ } ) } @new_grid;
return( \@new_grid, @new_grid_string );
}
sub grid_is_winner
{
my ( $ref2grid ) = @_;
my ( $check_x, $check_y );
for( my $y = $GRID_Y_MAX; $y >= 0; $y-- )
{
for( my $x = $GRID_X_MAX; $x >= 0; $x-- )
{
if( ${ $ref2grid }[$y][$x] eq $win{block} )
{
( $check_x, $check_y ) = ( $x, $y );
}
}
}
return ( $check_x == $win{x} and $check_y == $win{y} ) ? 1 : 0;
}
Now I'm going to see how the other solutions work... :)