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' ) {
say "No bullet specified";
exit 0;
}
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 {
say "Overlapping pieces";
exit 0;
}
}
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 ) {
# I should probably generate a hash instead using <FROM> as keys.
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 );
}
This version of the program is identical to the previous one, save for its correcting a few error messages for the benefit of the testing framework:
89c89,90
< die "Piece l12 missing.";
---
> say "No bullet specified";
> exit 0;
98c99,100
< die "Overlapping pieces.";
---
> say "Overlapping pieces";
> exit 0;
And introducing the following comment:
# I should probably generate a hash instead using <FROM> as keys.
Sounds interesting. We would probably have liked to see such a solution. :-)