#!/usr/bin/perl -w
use strict;
# A board is a string of 35 characters showing current positions
# and last move or two (so we don't just undo the last move):
# ,----. ,----. ,----. ,----. ,----. ,----. ,----. ,----.
# |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB|
# |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB| |AXXB|
# | HH | |HH< | |HH2 | |HH2 | |HH>2| |HH42| |HH42| |HH4v|
# |C12D| |C12D| |C1^D| |C14D| |C14D| |C1^D| |C1D<| |C1D2|
# |C34D| |C34D| |C34D| |C3^D| |C3 D| |C3 D| |C3D<| |C3D |
# `----' `----' `----' `----' `----' `----' `----' `----'
# H< H<2^ H<2^4^ ...
# On the end of the board we keep all the moves needed.
# We start with just one board and build the list of boards
# we can get with one more move.
$|= 1;
my $start= "#####AXXB#AXXB# HH #C12D#C34D######";
my @boards= $start;
my %double;
@double{ qw( A< A> B< B> C< C> D< D> H^ Hv X< X> X^ Xv ) }
= (1) x 14;
my %offset= qw( < -1 > +1 ^ -5 v +5 );
my %size= qw( 1 1 2 1 3 1 4 1 A 2 B 2 C 2 D 2 H 2 X 4 );
my %back= qw( < > > < ^ v v ^ );
$back{' '}= ' ';
my @MovedX;
my $moves= 0;
my $dupCount= 1;
my %uniq;
while( 1 ) {
@MovedX= ();
print "Considering ", 0+@boards,
" of $dupCount boards after $moves moves...\n";
Dump( @boards ) if @ARGV;
@boards= map MoveAny($_), @boards;
$dupCount= @boards;
@boards= grep {
my $board= substr( $_, 0, 35 );
$board =~ tr[<>^v1234ABCDH]
[ OOOO||||=];
! $uniq{$board}++;
} @boards;
$moves++;
# Dump( @MovedX );
}
sub MoveAny
{
my( $board )= @_;
my @boards;
$board =~ /[<>v^ ]/g or die $board; my @gap= pos($board)-1;
$board =~ /[<>v^ ]/g or die $board; push @gap, pos($board)-1;
my %can;
for my $gap ( @gap ) {
my $skip= $back{substr($board,$gap,1,' ')};
for my $dir ( keys %offset ) {
next if $skip eq $dir;
my $off= $offset{$dir};
my $block= substr($board,$gap-$off,1);
next if ! $size{$block};
if( ! $double{$block.$dir}
|| 2 <= ++$can{$block.$dir}
) {
push @boards, MoveThis( $board, $block, $dir, $off );
}
}
}
return @boards;
}
sub MoveThis
{
my( $board, $block, $dir, $off )= @_;
my @pos;
while( $board =~ /$block/g ) {
last if 30 < pos($board);
push @pos, pos($board)-1;
}
substr( $board, $_, 1, $dir ) for @pos;
substr( $board, $_+$off, 1, $block ) for @pos;
$board .= $block . $dir;
Win($board) if $board =~ /XX[^#]##/;
if( "X" eq $block ) {
push @MovedX, $board;
}
return $board;
}
sub Dump
{
my( @all )= @_;
while( @all ) {
my @boards= splice( @all, 0, 8 );
for my $line ( 0 .. 6 ) {
for my $board ( @boards ) {
print " #", substr($board,5*$line,5);
}
print $/;
}
if( 1 == @boards ) {
print " ", substr($boards[0],35);
} else {
for my $board ( @boards ) {
printf " %-6s", substr(substr($board,35),-6);
}
}
print $/;
}
}
my $won;
sub Win
{
return if $won++;
my( $board )= @_;
my @moves= substr($board,35) =~ /(..)/g;
print "\n @moves\n\n";
$board= $start;
my @boards= $board;
for my $move ( @moves ) {
my( $block, $dir )= $move =~ /(.)(.)/;
substr( $board, 35 )= '';
$board =~ tr/<>^v/ /;
$board= MoveThis( $board, $block, $dir, $offset{$dir} );
push @boards, $board;
}
Dump( @boards );
exit 0;
}
And the output:
H< 2^ 2> H> C^ 3< 4< D< 2v H> 1^ 4^ 3> Cv 1< H<
Bv 2v Bv X> A> 1^ 1^ C^ C^ 4< 3< D< 2< 2^ Bv H>
D^ 3> 3> Dv Av 1> C^ 4^ D< Av Av 4> 4^ H< H< B^
3> 2v B< 3^ 2> Bv H> Cv 1< 4^ H> A^ A^ B< 3< 3v
Hv Xv 4> 1> C^ 4> 1> A^ D^ B^ 3< 3< 2< 2< Hv Xv
1v 1> A> B^ B^ X< 1v 4v 1v 4v A> B> C> D^ D^ X<
4< 1^ H^ 2> 3> 2> 3> Xv 4< 4< 1< 1< H^ 3^ 3> X>
I didn't care to define "one move" to include moving the same piece more than one square, so 112 moves is the minimum w/o folding such moves together.
| 
