Download the raw code.
#!/usr/bin/env perl6
# This is perl6 version 2011.12-18-ga7fd89e built on parrot 3.11.0 revision RELEASE_3_11_0
=begin comment
- The list of all moves in a groove is generated before solving the puzzle.
- Moves are sorted from the shortest to the longest (so that a solution with the shortest moves is found first).
- Each field on the board is assigned one character (convenient for serialization).
- The board is analyzed with a regular BFS.
- Convertions between different notation types make the code appear more difficult than it really is.
- The script dies if the input is illegal.
=end comment
my @BOARDS =
[
<
e1 d1 c1 b1 a1
f1 e2 d2 c2 b2 a2
f2 e3 d3 c3 b3
g1 f3 e4 d4 c4 b4
g2 f4 e5 d5 c5
h1 g3 f5 e6 d6 c6
h2 g4 f6 e7 d7
>
],
[
<
i1 i2 i3 i4 i5
j1 j2 j3 j4 j5 j6
k1 k2 k3 k4 k5
l1 l2 l3 l4 l5 l6
m1 m2 m3 m4 m5
n1 n2 n3 n4 n5 n6
o1 o2 o3 o4 o5
>
],
[
<
p2 q4 r6 s7 t7
p1 q3 r5 s6 t6 u6
q2 r4 s5 t5 u5
q1 r3 s4 t4 u4 v4
r2 s3 t3 u3 v3
r1 s2 t2 u2 v2 w2
s1 t1 u1 v1 w1
>
];
# Auxilliary routines
sub fill-dictionary ( %dict is rw, @board ) {
my $num = ord( ' ' );
for @board -> $f {
%dict{ $f } = chr( ++$num ); # Encode each field into a single char.
}
}
sub encode-piece ( $piece, %field-dict ) { # Changes g123 to g1g2g3 and encodes.
my $groove = $piece.substr( 0, 1 );
my $result;
for $piece.substr( 1 ).split('') -> $num {
my $field = $groove ~ $num;
die "Field $field not on board." unless %field-dict.exists( $field );
$result ~= %field-dict{ $field };
}
return $result;
}
# Reading the board and initializing data structures
sub read-board () {
my %layout;
for lines() -> $piece {
$piece.chomp;
%layout{ $piece } = 1;
}
return %layout;
}
sub assert-board ( %initial-layout, %layout ) {
if not %initial-layout.exists( 'l12' ) {
die "Piece l12 missing.";
}
my %board = layout-to-board( %layout );
my $fields-in-layout = 0;
for %layout.keys -> $k {
$fields-in-layout += $k.chars;
}
if $fields-in-layout != %board.keys.elems {
die "Overlapping pieces.";
}
}
sub moves-in-groove ( $length, @fields ) {
my @result;
for 0 .. @fields.elems - $length -> $start-pos {
for 0 .. @fields.elems - $length -> $end-pos {
next if $start-pos == $end-pos;
my $from = @fields[ $start-pos .. $start-pos + $length - 1 ].join( '' );
my $to = @fields[ $end-pos .. $end-pos + $length - 1 ].join( '' );
my @must-be-empty-fields;
if $start-pos < $end-pos > 0 {
@must-be-empty-fields = @fields[ $start-pos + $length .. $end-pos + $length - 1 ];
}
else {
@must-be-empty-fields = @fields[ $end-pos .. $start-pos - 1 ];
}
@result.push( [ $from, $to, @must-be-empty-fields.join(',') ] );
}
}
return @result;
}
sub generate-all-moves ( %initial-layout, %field-to-id ) {
my @moves;
my %grooves-seen;
for %initial-layout.keys -> $piece {
my $groove = $piece.substr( 0, 1 );
my $length = $piece.chars - 1;
next if %grooves-seen.exists( { $groove ~ $length } );
my @fields = %field-to-id.keys.grep( { .substr( 0, 1 ) eq $groove } ).sort.map( { %field-to-id{$_} } );
my @arr = moves-in-groove( $length, @fields );
@moves.push( moves-in-groove( $length, @fields ) );
%grooves-seen{ $groove ~ $length } = 1;
}
return @moves;
}
# Board analysis
sub check-l-groove ( %initial-layout ) { # Return false if there is more than one piece on groove L.
for %initial-layout.keys -> $k {
return if $k.substr( 0, 1 ) eq 'l' && $k ne 'l12';
}
return 1;
}
sub transform-layout( %layout, $transformation ) {
my %new-layout = %layout;
return %new-layout unless $transformation.chars;
for $transformation.split( ' ' ) -> $from, $to {
%new-layout.delete( $from );
%new-layout{ $to } = 1;
}
return %new-layout;
}
sub layout-to-board( %layout ) {
my @fields = %layout.keys.map( { $_.split( '' ) } );
my %board;
%board{ @fields } = ( 1 ) xx %board.elems;
return %board;
}
sub solve ( %initial-layout, @moves, $success ) {
my @queue;
my @next-queue = "";
my %positions_seen;
loop {
if @next-queue.elems == 0 {
return;
}
( @queue, @next-queue ) .= reverse();
@next-queue = ();
for @queue -> $history {
my %layout = transform-layout( %initial-layout, $history );
my %board = layout-to-board( %layout );
for @moves -> $from, $to, $fields {
# Check if a piece is placed in the $from position.
next unless %layout.exists( $from );
# Check if fields required for move are empty.
next if grep { %board.exists( $_ ) }, $fields.split( '' );
# Transform and serialize board
for $from.split( '' ) -> $f { %board.delete( $f ); }
for $to.split( '' ) -> $f { %board{ $f } = 1; }
my $key = %board.keys.sort.join( '' );
for $to.split( '' ) -> $f { %board.delete( $f ); }
for $from.split( '' ) -> $f { %board{ $f } = 1; }
next if %positions_seen.exists( $key );
%positions_seen{$key} = 1;
my $new-move = ( $history.chars ?? "$history " !! '' ) ~ "$from $to";
if $to eq $success {
return $new-move;
}
@next-queue.push( $new-move );
}
}
}
}
# Arghhh, have the solution but have to print it in the desired format
sub decode-piece ( $piece, @boards ) {
my @pos = $piece.split( '' ).map( { ord( $_ ) - ord( ' ' ) - 1 } );
for 0 .. @boards.end -> $i {
my @alpha-fields = @pos.map( { @boards[$i][$_] } );
if @alpha-fields[0].substr( 0, 1 ) eq @alpha-fields[1].substr( 0, 1 ) {
my $result = @alpha-fields.shift ~ @alpha-fields.map( { $_.substr( 1 ) } ).join( '' );
return $result;
}
}
die "Corrupted input.";
}
sub decode-result ( $moves, @boards ) {
return "No solution.\n" unless $moves.chars;
my $result;
for $moves.split( ' ' ) -> $from, $to {
my $f = decode-piece( $from, @boards );
my $t = decode-piece( $to, @boards );
$result ~= $f.substr( 0, 1 ) ~ '[' ~ $f.substr( 1 );
$result ~= ' -> ' ~ $t.substr( 1 ) ~ "]\n";
}
return $result;
}
sub MAIN {
my %field-to-id;
for 0 .. @BOARDS.end -> $i {
fill-dictionary( %field-to-id, @BOARDS[ $i ] );
}
my %initial-layout = read-board( );
my %layout = %initial-layout.keys.map( { encode-piece( $_, %field-to-id ), 1 } );
assert-board( %initial-layout, %layout );
my $result = '';
if check-l-groove( %initial-layout ) {
my @moves = generate-all-moves( %initial-layout, %field-to-id );
# Sort the moves (shortest first) and then flatten the array of arrays.
@moves = @moves.sort( { $^a[2].chars <=> $^b[2].chars } ).map( { @($_) } );
$result = solve( %layout, @moves, encode-piece( 'l56', %field-to-id ) );
};
print decode-result( $result, @BOARDS );
}
The algorithm is a BFS on the graph of all board configurations reachable by single moves. It seems correct.
These lines are calling the same sub twice in a row, only using the result from the second call.
my @arr = moves-in-groove( $length, @fields );
@moves.push( moves-in-groove( $length, @fields ) );
So the first line can be removed and the program will still work.
Internally in the program, board positions and moves are stored with a home-grown format where each position corresponds to one ASCII character. Conversions between this representation and the one at the program endpoints are legion:
# Arghhh, have the solution but have to print it in the desired format
In solve, there isn't any need for both @queue (for consuming elements) and
@next-queue (for producing elements). One queue is enough.
This being a normal BFS, the worst-case running time is proportional to the total number of reachable board configurations. It fares worse than the two A star solutions submitted.
Superstitious parentheses in ( 1 ) xx %board.elems.
.split( '' ) better written .comb in Perl 6.
The program is not huge, but could definitely be shorter.
For example, the moves-in-groove and generate-all-moves pre-generate all
the moves from grooves with pieces in them in the initial configuration.
However, it would have been both shorter and faster to simply consider the
moves available to each piece on a need-to-calculate basis.