Download the raw code.
#!/usr/local/bin/perl6
## ======================================================================== ##
## Hex Puzzle solver
##
## This code uses a variant of A-star search to try to find a reasonable
## and efficient set of moves to solve the puzzle. For speed purposes,
## I rely on a set of precomputed tables to make it easy to determine
## piece collisions and movement possibilities.
## ======================================================================== ##
## ------------------------------------------------------------------------ ##
## Resource Tracking Bitmaps
##
## Represent all piece positions as 38-bit bitmaps. Two pieces coexist
## if the bit-wise and between their bitmaps is 0.
##
## Bit position assignments are in left-to-right order from the original
## hexagon graph, starting with i1 in bit 37 and ending with o5 in bit 0.
## ------------------------------------------------------------------------ ##
my %piece_bmp =
(
# iiiii jjjjjj kkkkk llllll mmmmm nnnnnn ooooo
# 12345 123456 12345 123456 12345 123456 12345
i12 => 0b11000_000000_00000_000000_00000_000000_00000,
i23 => 0b01100_000000_00000_000000_00000_000000_00000,
i34 => 0b00110_000000_00000_000000_00000_000000_00000,
i45 => 0b00011_000000_00000_000000_00000_000000_00000,
i123 => 0b11100_000000_00000_000000_00000_000000_00000,
i234 => 0b01110_000000_00000_000000_00000_000000_00000,
i345 => 0b00111_000000_00000_000000_00000_000000_00000,
j12 => 0b00000_110000_00000_000000_00000_000000_00000,
j23 => 0b00000_011000_00000_000000_00000_000000_00000,
j34 => 0b00000_001100_00000_000000_00000_000000_00000,
j45 => 0b00000_000110_00000_000000_00000_000000_00000,
j56 => 0b00000_000011_00000_000000_00000_000000_00000,
j123 => 0b00000_111000_00000_000000_00000_000000_00000,
j234 => 0b00000_011100_00000_000000_00000_000000_00000,
j345 => 0b00000_001110_00000_000000_00000_000000_00000,
j456 => 0b00000_000111_00000_000000_00000_000000_00000,
k12 => 0b00000_000000_11000_000000_00000_000000_00000,
k23 => 0b00000_000000_01100_000000_00000_000000_00000,
k34 => 0b00000_000000_00110_000000_00000_000000_00000,
k45 => 0b00000_000000_00011_000000_00000_000000_00000,
k123 => 0b00000_000000_11100_000000_00000_000000_00000,
k234 => 0b00000_000000_01110_000000_00000_000000_00000,
k345 => 0b00000_000000_00111_000000_00000_000000_00000,
l12 => 0b00000_000000_00000_110000_00000_000000_00000,
l23 => 0b00000_000000_00000_011000_00000_000000_00000,
l34 => 0b00000_000000_00000_001100_00000_000000_00000,
l45 => 0b00000_000000_00000_000110_00000_000000_00000,
l56 => 0b00000_000000_00000_000011_00000_000000_00000,
l123 => 0b00000_000000_00000_111000_00000_000000_00000,
l234 => 0b00000_000000_00000_011100_00000_000000_00000,
l345 => 0b00000_000000_00000_001110_00000_000000_00000,
l456 => 0b00000_000000_00000_000111_00000_000000_00000,
m12 => 0b00000_000000_00000_000000_11000_000000_00000,
m23 => 0b00000_000000_00000_000000_01100_000000_00000,
m34 => 0b00000_000000_00000_000000_00110_000000_00000,
m45 => 0b00000_000000_00000_000000_00011_000000_00000,
m123 => 0b00000_000000_00000_000000_11100_000000_00000,
m234 => 0b00000_000000_00000_000000_01110_000000_00000,
m345 => 0b00000_000000_00000_000000_00111_000000_00000,
n12 => 0b00000_000000_00000_000000_00000_110000_00000,
n23 => 0b00000_000000_00000_000000_00000_011000_00000,
n34 => 0b00000_000000_00000_000000_00000_001100_00000,
n45 => 0b00000_000000_00000_000000_00000_000110_00000,
n56 => 0b00000_000000_00000_000000_00000_000011_00000,
n123 => 0b00000_000000_00000_000000_00000_111000_00000,
n234 => 0b00000_000000_00000_000000_00000_011100_00000,
n345 => 0b00000_000000_00000_000000_00000_001110_00000,
n456 => 0b00000_000000_00000_000000_00000_000111_00000,
o12 => 0b00000_000000_00000_000000_00000_000000_11000,
o23 => 0b00000_000000_00000_000000_00000_000000_01100,
o34 => 0b00000_000000_00000_000000_00000_000000_00110,
o45 => 0b00000_000000_00000_000000_00000_000000_00011,
o123 => 0b00000_000000_00000_000000_00000_000000_11100,
o234 => 0b00000_000000_00000_000000_00000_000000_01110,
o345 => 0b00000_000000_00000_000000_00000_000000_00111,
# edcba fedcba fedcb gfedcb gfedc hgfedc hgfed
# 11111 122222 23333 134444 24555 135666 24677
a12 => 0b00001_000001_00000_000000_00000_000000_00000,
# 1 2 3 4
b12 => 0b00010_000010_00000_000000_00000_000000_00000,
b23 => 0b00000_000010_00001_000000_00000_000000_00000,
b34 => 0b00000_000000_00001_000001_00000_000000_00000,
b123 => 0b00010_000010_00001_000000_00000_000000_00000,
b234 => 0b00000_000010_00001_000001_00000_000000_00000,
# 1 2 3 4 5 6
c12 => 0b00100_000100_00000_000000_00000_000000_00000,
c23 => 0b00000_000100_00010_000000_00000_000000_00000,
c34 => 0b00000_000000_00010_000010_00000_000000_00000,
c45 => 0b00000_000000_00000_000010_00001_000000_00000,
c56 => 0b00000_000000_00000_000000_00001_000001_00000,
c123 => 0b00100_000100_00010_000000_00000_000000_00000,
c234 => 0b00000_000100_00010_000010_00000_000000_00000,
c345 => 0b00000_000000_00010_000010_00001_000000_00000,
c456 => 0b00000_000000_00000_000010_00001_000001_00000,
# 1 2 3 4 5 6 7
d12 => 0b01000_001000_00000_000000_00000_000000_00000,
d23 => 0b00000_001000_00100_000000_00000_000000_00000,
d34 => 0b00000_000000_00100_000100_00000_000000_00000,
d45 => 0b00000_000000_00000_000100_00010_000000_00000,
d56 => 0b00000_000000_00000_000000_00010_000010_00000,
d67 => 0b00000_000000_00000_000000_00000_000010_00001,
d123 => 0b01000_001000_00100_000000_00000_000000_00000,
d234 => 0b00000_001000_00100_000100_00000_000000_00000,
d345 => 0b00000_000000_00100_000100_00010_000000_00000,
d456 => 0b00000_000000_00000_000100_00010_000010_00000,
d567 => 0b00000_000000_00000_000000_00010_000010_00001,
# 1 2 3 4 5 6 7
e12 => 0b10000_010000_00000_000000_00000_000000_00000,
e23 => 0b00000_010000_01000_000000_00000_000000_00000,
e34 => 0b00000_000000_01000_001000_00000_000000_00000,
e45 => 0b00000_000000_00000_001000_00100_000000_00000,
e56 => 0b00000_000000_00000_000000_00100_000100_00000,
e67 => 0b00000_000000_00000_000000_00000_000100_00010,
e123 => 0b10000_010000_01000_000000_00000_000000_00000,
e234 => 0b00000_010000_01000_001000_00000_000000_00000,
e345 => 0b00000_000000_01000_001000_00100_000000_00000,
e456 => 0b00000_000000_00000_001000_00100_000100_00000,
e567 => 0b00000_000000_00000_000000_00100_000100_00010,
# 1 2 3 4 5 6
f12 => 0b00000_100000_10000_000000_00000_000000_00000,
f23 => 0b00000_000000_10000_010000_00000_000000_00000,
f34 => 0b00000_000000_00000_010000_01000_000000_00000,
f45 => 0b00000_000000_00000_000000_01000_001000_00000,
f56 => 0b00000_000000_00000_000000_00000_001000_00100,
f123 => 0b00000_100000_10000_010000_00000_000000_00000,
f234 => 0b00000_000000_10000_010000_01000_000000_00000,
f345 => 0b00000_000000_00000_010000_01000_001000_00000,
f456 => 0b00000_000000_00000_000000_01000_001000_00100,
# 1 2 3 4
g12 => 0b00000_000000_00000_100000_10000_000000_00000,
g23 => 0b00000_000000_00000_000000_10000_010000_00000,
g34 => 0b00000_000000_00000_000000_00000_010000_01000,
g123 => 0b00000_000000_00000_100000_10000_010000_00000,
g234 => 0b00000_000000_00000_000000_10000_010000_01000,
# 1 2
h34 => 0b00000_000000_00000_000000_00000_100000_10000,
# pqrst pqrstu qrstu qrstuv rstuv rstuvw stuvw
# 24677 135666 24555 134444 23333 122222 11111
p12 => 0b10000_100000_00000_000000_00000_000000_00000,
# 4 3 2 1
q12 => 0b00000_000000_10000_100000_00000_000000_00000,
q23 => 0b00000_010000_10000_000000_00000_000000_00000,
q34 => 0b01000_010000_00000_000000_00000_000000_00000,
q123 => 0b00000_010000_10000_100000_00000_000000_00000,
q234 => 0b01000_010000_10000_000000_00000_000000_00000,
# 6 5 4 3 2 1
r12 => 0b00000_000000_00000_000000_10000_100000_00000,
r23 => 0b00000_000000_00000_010000_10000_000000_00000,
r34 => 0b00000_000000_01000_010000_00000_000000_00000,
r45 => 0b00000_001000_01000_000000_00000_000000_00000,
r56 => 0b00100_001000_00000_000000_00000_000000_00000,
r123 => 0b00000_000000_00000_010000_10000_100000_00000,
r234 => 0b00000_000000_01000_010000_10000_000000_00000,
r345 => 0b00000_001000_01000_010000_00000_000000_00000,
r456 => 0b00100_001000_01000_000000_00000_000000_00000,
# 7 6 5 4 3 2 1
s12 => 0b00000_000000_00000_000000_00000_010000_10000,
s23 => 0b00000_000000_00000_000000_01000_010000_00000,
s34 => 0b00000_000000_00000_001000_01000_000000_00000,
s45 => 0b00000_000000_00100_001000_00000_000000_00000,
s56 => 0b00000_000100_00100_000000_00000_000000_00000,
s67 => 0b00010_000100_00000_000000_00000_000000_00000,
s123 => 0b00000_000000_00000_000000_01000_010000_10000,
s234 => 0b00000_000000_00000_001000_01000_010000_00000,
s345 => 0b00000_000000_00100_001000_01000_000000_00000,
s456 => 0b00000_000100_00100_001000_00000_000000_00000,
s567 => 0b00010_000100_00100_000000_00000_000000_00000,
# 7 6 5 4 3 2 1
t12 => 0b00000_000000_00000_000000_00000_001000_01000,
t23 => 0b00000_000000_00000_000000_00100_001000_00000,
t34 => 0b00000_000000_00000_000100_00100_000000_00000,
t45 => 0b00000_000000_00010_000100_00000_000000_00000,
t56 => 0b00000_000010_00010_000000_00000_000000_00000,
t67 => 0b00001_000010_00000_000000_00000_000000_00000,
t123 => 0b00000_000000_00000_000000_00100_001000_01000,
t234 => 0b00000_000000_00000_000100_00100_001000_00000,
t345 => 0b00000_000000_00010_000100_00100_000000_00000,
t456 => 0b00000_000010_00010_000100_00000_000000_00000,
t567 => 0b00001_000010_00010_000000_00000_000000_00000,
# 6 5 4 3 2 1
u12 => 0b00000_000000_00000_000000_00000_000100_00100,
u23 => 0b00000_000000_00000_000000_00010_000100_00000,
u34 => 0b00000_000000_00000_000010_00010_000000_00000,
u45 => 0b00000_000000_00001_000010_00000_000000_00000,
u56 => 0b00000_000001_00001_000000_00000_000000_00000,
u123 => 0b00000_000000_00000_000000_00010_000100_00100,
u234 => 0b00000_000000_00000_000010_00010_000100_00000,
u345 => 0b00000_000000_00001_000010_00010_000000_00000,
u456 => 0b00000_000001_00001_000010_00000_000000_00000,
# 4 3 2 1
v12 => 0b00000_000000_00000_000000_00000_000010_00010,
v23 => 0b00000_000000_00000_000000_00001_000010_00000,
v34 => 0b00000_000000_00000_000001_00001_000000_00000,
v123 => 0b00000_000000_00000_000000_00001_000010_00010,
v234 => 0b00000_000000_00000_000001_00001_000010_00000,
# 2 1
w12 => 0b00000_000000_00000_000000_00000_000001_00001,
);
## ------------------------------------------------------------------------ ##
## Movement Connectivity
##
## %succ moves a piece toward the next higher index in its groove.
## %pred moves a piece toward the next lower index.
##
## A move in a particular direction is allowed if and only if
## .contains($curr) == True for that direction.
## ------------------------------------------------------------------------ ##
my %succ =
(
i12 => 'i23', i23 => 'i34', i34 => 'i45',
j12 => 'j23', j23 => 'j34', j34 => 'j45', j45 => 'j56',
k12 => 'k23', k23 => 'k34', k34 => 'k45',
l12 => 'l23', l23 => 'l34', l34 => 'l45', l45 => 'l56',
m12 => 'm23', m23 => 'm34', m34 => 'm45',
n12 => 'n23', n23 => 'n34', n34 => 'n45', n45 => 'n56',
o12 => 'o23', o23 => 'o34', o34 => 'o45',
i123 => 'i234', i234 => 'i345',
j123 => 'j234', j234 => 'j345', j345 => 'j456',
k123 => 'k234', k234 => 'k345',
l123 => 'l234', l234 => 'l345', l345 => 'l456',
m123 => 'm234', m234 => 'm345',
n123 => 'n234', n234 => 'n345', n345 => 'n456',
o123 => 'o234', o234 => 'o345',
b12 => 'b23', b23 => 'b34',
c12 => 'c23', c23 => 'c34', c34 => 'c45', c45 => 'c56',
d12 => 'd23', d23 => 'd34', d34 => 'd45', d45 => 'd56', d56 => 'd67',
e12 => 'e23', e23 => 'e34', e34 => 'e45', e45 => 'e56', e56 => 'e67',
f12 => 'f23', f23 => 'f34', f34 => 'f45', f45 => 'f56',
g12 => 'g23', g23 => 'g34',
b123 => 'b234',
c123 => 'c234', c234 => 'c345', c345 => 'c456',
d123 => 'd234', d234 => 'd345', d345 => 'd456', d456 => 'd567',
e123 => 'e234', e234 => 'e345', e345 => 'e456', e456 => 'e567',
f123 => 'f234', f234 => 'f345', f345 => 'f456',
g123 => 'g234',
q12 => 'q23', q23 => 'q34',
r12 => 'r23', r23 => 'r34', r34 => 'r45', r45 => 'r56',
s12 => 's23', s23 => 's34', s34 => 's45', s45 => 's56', r56 => 'r67',
t12 => 't23', t23 => 't34', t34 => 't45', t45 => 't56', s56 => 's67',
u12 => 'u23', u23 => 'u34', u34 => 'u45', u45 => 'u56',
v12 => 'v23', v23 => 'v34',
q123 => 'q234',
r123 => 'r234', r234 => 'r345', r345 => 'r456',
s123 => 's234', s234 => 's345', s345 => 's456', s456 => 's567',
t123 => 't234', t234 => 't345', t345 => 't456', t456 => 't567',
u123 => 'u234', u234 => 'u345', u345 => 'u456',
v123 => 'v234',
);
my %pred = %succ.invert;
## ------------------------------------------------------------------------ ##
## Helper function: Render a from/to as a move in desired output format
## ------------------------------------------------------------------------ ##
sub render_move(Str $from, Str $to)
{
return $from.substr(0, 1)
~ "[" ~ $from.substr(1) ~ " -> " ~ $to.substr(1) ~ "]";
}
## ------------------------------------------------------------------------ ##
## Priority Queue
##
## This is a simple priority queue class. It uses a hash, keying on the
## "metric" value for each entry. It returns the key with the lowest
## metric.
##
## The only requirement prio-queue places on its input is that it must
## support a method named "metric".
## ------------------------------------------------------------------------ ##
class prio-queue {
has %!q;
has $!elems;
method push($item) {
my $key = $item.metric;
$!elems++;
%!q{$key} = my @q if !%!q.contains($key);
%!q{$key}.push( $item );
}
method pop() {
return if @( %!q.keys ).elems == 0;
# "There is a min_key in my rhim." -- Inspector Clousseau
my $min_key = %!q.keys.min;
my $best = @( %!q.{$min_key} ).shift;
%!q.delete($min_key) if ( ! %!q.{$min_key}.elems );
$!elems--;
return $best;
}
method unshift($item) { return self.push($item); }
method shift() { return self.pop(); }
method elems() {
return $!elems;
}
};
## ------------------------------------------------------------------------ ##
## A-star Search
##
## Note that this implementation goes light on the abstraction. That can
## always be added later when it's time to reuse the code.
##
## The class a-star-node encapsulates a single state node from the
## state tree search. The class a-star encapsulates knowledge of visited
## states and handles iterating the actual a-star search.
## ------------------------------------------------------------------------ ##
class a-star-node
{
has Int $!cost;
has Str $!move;
has Int $!in_use;
has @!pieces;
has Bool $!bullet;
has Str $!parent;
has Int $!est_cost;
method Str() {
return @!pieces.join();
}
method is_goal() {
return @!pieces[0] eq 'l56';
}
method add_piece(Str $piece) {
# This is used only when populating start nodes from the input
say "Invalid piece name." and exit(1)
if !%piece_bmp.contains($piece);
my $new_bmp = %piece_bmp{$piece};
say "Overlapping pieces." and exit(1) if $!in_use +& $new_bmp;
$!in_use +|= $new_bmp;
if ($piece eq 'l12') {
$!bullet = True;
unshift @!pieces, $piece;
} else {
say "No solution." and exit(1) if $piece.substr(0,1) eq 'l';
push @!pieces, $piece;
}
}
method has_bullet {
# This is used only when populating start nodes from the input
return $!bullet;
}
method get_moves {
my (Int $piece, Int $cost, Str $orig, Str $curr, Int $others,
Int $p, $next, @moves);
## Try to move each piece as far backward as possible,
## then try to move each piece as far forward as possible.
##
## Cost of the move is 3 + # of segments.
##
## Insert the options into the result buffer in reverse
## order, so the first move we consider is the one that
## moves the bullet the furthest right.
for $(%pred), $(%succ) -> $next {
for @!pieces.elems-1 ... 0 -> $p {
my @p_copy = @!pieces;
$curr = $orig = @!pieces[$p];
$cost = $!cost + 1;
$others = $!in_use +^ %piece_bmp{$orig};
while ( $next.contains($curr) ) {
$curr = $next{$curr};
$cost++;
if ($others +& %piece_bmp{$curr}) == 0 {
@p_copy[$p] = $curr;
@moves.unshift(
a-star-node.new(
cost => $cost,
move => render_move($orig, $curr),
in_use => $others +| %piece_bmp{$curr},
pieces => @p_copy,
bullet => $!bullet,
parent => self.Str
)
)
} else {
last;
}
}
}
}
return @moves;
}
method get_parent { return $!parent; }
method get_move { return $!move; }
method tot_cost_to_here {
# Actual cost incurred getting to this node.
return $!cost;
}
method est_cost_to_goal {
return $!est_cost if $!est_cost > 0;
# Estimated cost to get from this node to the goal state.
#
# Our heuristic:
# -- Number of slots the bullet needs to slide, plus
# -- Number of other piece segments overlapping l1 .. l6 to
# the right of the bullet, plus
# -- 1, to cover the minimum cost of any move.
#
# Because we start calculating "overlapping piece segments"
# on the right-edge of the "bullet", we don't need to add 1
# explicitly.
my Int $bull_pos = @!pieces[0].substr(1,1).Int;
my Int $in_way = 0;
my Int $bit_num;
for (21 - $bull_pos) ... 16 -> $bit_num {
$in_way += ($!in_use +> $bit_num) +& 1;
}
return $!est_cost = ( 5 - $bull_pos ) + $in_way;
}
method metric {
return self.est_cost_to_goal + $!cost;
}
submethod BUILD
(
:$!cost = 0,
:$!move = '',
:$!in_use = 0,
:@!pieces = ( ),
:$!bullet = False,
:$!parent = 'START',
:$!est_cost = -1
) {
}
};
class a-star
{
has %!visited;
has $!frontier;
method !visit(a-star-node $state) {
my Str $str = $state.Str;
my Bool $was_visited = %!visited.contains($str);
%!visited{$str} = $state
if (!$was_visited ||
$state.tot_cost_to_here < %!visited{$str}.tot_cost_to_here);
return $was_visited;
}
method !best_path(a-star-node $end) {
my @moves;
my $state = $end.Str;
while (%!visited.contains($state)) {
@moves.unshift( %!visited{$state}.get_move );
$state = %!visited{$state}.get_parent;
}
shift @moves; ## remove extra move from last iter
return @moves;
}
method search {
my (a-star-node $node, a-star-node $exit);
my (@exits, $curr);
while ($!frontier.elems > 0) {
$node = $!frontier.pop;
$curr = $node.Str;
if $node.is_goal {
return self!best_path($node);
}
@exits = $node.get_moves;
for @exits -> $exit {
$!frontier.push($exit) if self!visit($exit) == 0;
}
}
return @( );
}
submethod BUILD(:$start) {
my $!frontier = prio-queue.new;
$!frontier.push($start); ## like an old Ford
self!visit($start);
}
};
## ======================================================================== ##
## MAIN PROGRAM
## ======================================================================== ##
sub MAIN
{
my $start = a-star-node.new;
for lines() {
$start.add_piece( $_ );
}
say "No bullet specified" and exit(1) if !$start.has_bullet;
my $a-star = a-star.new(start => $start);
my @path = $a-star.search;
if @path.elems {
say @path.join("\n");
} else {
say "No solution.";
}
}
This version sees the addition of a priority queue class, helping prioritize the order to look at the board configurations.
The author also felt the previous version wasn't -Ofun enough, and so
inserted two frivolous comments into this one. :-)
This version accidentally introduces the line my $!frontier = prio-queue.new;
inside the BUILD submethod of class a-star. The error goes unnoticed because
the program is run on a pre-nom Rakudo, which accepts it without complaining.
A later version of the program is run on the nom branch, and the problem fixed.
A bug is also introduced in this version such that it, and all subsequent versions fail to find the most efficient solutions in some cases. For example, given this input:
l12
s56
v234
The program emits:
s[56 -> 23]
v[234 -> 123]
l[12 -> 56]
But the first move s[56 -> 23] is superfluous. This is fixed in the next
version.
The method name !pick was now refactored away and replaced, as hoped, by a
method call .pop on the priority queue.
Superstitious parentheses (the ones around the condition):
%!q.delete($min_key) if ( ! %!q.{$min_key}.elems );
The elems accessor can be folded into the attribute by just re-twigilling it
as has $.elems.