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( :by({ $^a <=> $^b }) );
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 1 + # 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;
has $!best_goal;
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);
$!best_goal = $state
if $state.is_goal &&
(!$!best_goal.defined ||
$state.tot_cost_to_here < $!best_goal.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($!best_goal);
}
@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 introduces the $!best_goal attribute into the A star search, to
make it return not just the path to the latest goal configuration found, but
the path to the best configuration found so far.
As you can see from the diff below, the $!best_goal attribute minimizes on
total path cost.
509a510
> has $!best_goal;
518a520,524
> $!best_goal = $state
> if $state.is_goal &&
> (!$!best_goal.defined ||
> $state.tot_cost_to_here < $!best_goal.tot_cost_to_here);
>
545c551
< return self!best_path($node);
---
> return self!best_path($!best_goal);