Download the raw code. And Grooves.pm6. And Heap.pm6.
# -*- mode: cperl6; -*-
# 2011 Perl 6 Coding Contest
# Edgar Gonzà lez i Pellicer
use v6;
use Grooves;
use Heap;
# Piece movement string
sub piece-movement-str(Piece $p, Int $offset) {
return "{$p.groove}[{($p.start .. $p.end).join} -> " ~
"{(($p.start .. $p.end) <<+>> $offset).join}]";
}
# State
class State {
has @.movements;
has $.board;
}
# A* search
# If the heuristic is optimistic, the solution found has minimal cost
# (i.e., number of movements)
sub a-star(Board $start) {
# Is it final?
return if $start.is-final;
# State heap
my $states = MinHeap.new;
# Insert the starting one
$states.push($start.heuristic-cost, State.new(board => $start));
# Visited
my %visited = $start => 1;
# Not empty?
while !$states.empty {
# Get the state with the lowest cost so far
my $cur = $states.top.value;
$states.pop;
# For each piece and movement
for $cur.board.pieces -> $p {
for $cur.board.piece-movements($p) -> $m {
# Make the move
my $new-board = $cur.board.move-piece($p, $m);
# Is it resulting board already visited?
my $hash = $new-board.hash-str;
if !%visited{$hash} {
# Mark it
%visited{$hash} = 1;
# New movement list
my @new-movements = $cur.movements;
@new-movements.push(piece-movement-str($p, $m));
# Is it final?
return @new-movements if $new-board.is-final;
# New state
my $new-state = State.new(movements => @new-movements,
board => $new-board);
# Insert it into the heap
$states.push(@new-movements.elems + $new-board.heuristic-cost,
$new-state);
}
}
}
}
# Nothing found
die "No solution.";
}
# Main
multi sub MAIN() {
# Read the starting board
my Board $start = read-board($*IN);
# Solve it
my @movements = a-star($start);
.say for @movements;
# Exception
CATCH {
# Show exception message
.say;
# Don't rethrow
default {}
}
}
# Call main
# @maybe This should be done automatically?
MAIN(|@*ARGS);
Grooves.pm6:
# -*- mode: cperl6; -*-
# 2011 Perl 6 Coding Contest
# Edgar Gonzàlez i Pellicer
# Grooves game
module Grooves;
# The board is represented as:
# (0, 1) (0, 3) (0, 5) (0, 7) (0, 9)
# (1, 0) (1, 2) (1, 4) (1, 6) (1, 8) (1, 10)
# (2, 1) (2, 3) (2, 5) (2, 7) (2, 9)
# (3, 0) (3, 2) (3, 4) (3, 6) (3, 8) (3, 10)
# (4, 1) (4, 3) (4, 5) (4, 7) (4, 9)
# (5, 0) (5, 2) (5, 4) (5, 6) (5, 8) (5, 10)
# (6, 1) (6, 3) (6, 5) (6, 7) (6, 9)
# A groove then corresponds to a starting position and a direction
my %grooves =
# 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
'a' => [ 0, 9, 1, 1 ],
'b' => [ 0, 7, 1, 1 ],
'c' => [ 0, 5, 1, 1 ],
'd' => [ 0, 3, 1, 1 ],
'e' => [ 0, 1, 1, 1 ],
'f' => [ 1, 0, 1, 1 ],
'g' => [ 3, 0, 1, 1 ],
'h' => [ 5, 0, 1, 1 ],
# 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
'i' => [ 0, 1, 0, 2 ],
'j' => [ 1, 0, 0, 2 ],
'k' => [ 2, 1, 0, 2 ],
'l' => [ 3, 0, 0, 2 ],
'm' => [ 4, 1, 0, 2 ],
'n' => [ 5, 0, 0, 2 ],
'o' => [ 6, 1, 0, 2 ],
# 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
'p' => [ 1, 0, -1, 1 ],
'q' => [ 3, 0, -1, 1 ],
'r' => [ 5, 0, -1, 1 ],
's' => [ 6, 1, -1, 1 ],
't' => [ 6, 3, -1, 1 ],
'u' => [ 6, 5, -1, 1 ],
'v' => [ 6, 7, -1, 1 ],
'w' => [ 6, 9, -1, 1 ];
# Piece
class Piece is export {
has Str $.groove;
has Int $.number;
has Int $.start;
has Int $.end;
has @.positions;
}
# Board
class Board is export {
has @.rows;
has @.pieces;
has Piece $.bullet;
# Make empty
method make-empty() {
# Create the rows
my @rows;
for ^7 -> $r {
@rows[$r] = [ 0 xx 5 + $r !%% 2 ];
}
# Set'em
@.rows = @rows;
}
# Hash string
method hash-str() {
return (@.rows.map: { .join }).join;
}
# Display it
method display() {
for keys(@.rows) -> $r {
my $row = @.rows[$r].join(' ');
$row = " $row" if $r %% 2;
say($row);
}
}
# Is it final
method is-final() {
# Does it have a bullet
die "No bullet specified" unless $.bullet.defined;
# Is the bullet in the end?
return $.bullet.positions[* - 1][1] == 10;
}
# Position exists
method pos-exists(Int $row, Int $col) {
# Validate row
return False if $row !~~ (0 .. 6);
# Validate column
if $row %% 2 {
return $col ~~ (1 .. 9) && $col !%% 2;
}
else {
return $col ~~ (0 .. 10) && $col %% 2;
}
}
# Check a position
method check-pos(Int $row, Int $col) {
die "Bad position ($row, $col)" if !self.pos-exists($row, $col);
}
# Pos value
method pos-value(Int $row, Int $col) {
# Validate
self.check-pos($row, $col);
# Get
return @.rows[$row][$col div 2];
}
# Reset a position
method reset-pos(Int $row, Int $col) {
# Validate
self.check-pos($row, $col);
# Empty
@.rows[$row][$col div 2] = 0;
}
# Set a position
method set-pos(Int $row, Int $col, Int $value) {
# Validate
self.check-pos($row, $col);
# Empty?
my $dcol = $col div 2;
if @.rows[$row][$dcol] == 0 {
# Set
@.rows[$row][$dcol] = $value;
}
else {
# Error!
die "Position ($row, $col) not empty";
}
}
# Add piece
method add-piece(Str $groove, Int $start, Int $end) {
# Get groove info
my ($r0, $c0, $dr, $dc) = %grooves{$groove}.list;
# Piece number
my $piece-no = @.pieces.elems + 1;
# Piece pos
my @piece-pos;
# Mark each position
for $start .. $end -> $i {
my $r = $r0 + $dr * ($i - 1);
my $c = $c0 + $dc * ($i - 1);
# Clean?
die "Piece overlaps: {$groove}{ ($start .. $end).join }"
if self.pos-value($r, $c);
# Mark
self.set-pos($r, $c, $piece-no);
# Add it
@piece-pos.push([ $r, $c ]);
}
# Add it
@.pieces.push(Piece.new(number => $piece-no,
groove => $groove,
start => $start,
end => $end,
positions => @piece-pos));
# Is it the bullet?
$.bullet = @.pieces[* - 1] if $groove eq 'l' && $start == 1 && $end == 2;
# Exception
CATCH {
# Revert pos
self.clear-pos(|$_) for @piece-pos;
# Rethrow
}
}
# Piece movements
method piece-movements(Piece $p) {
# Get the direction
my $dr = %grooves{$p.groove}[2];
my $dc = %grooves{$p.groove}[3];
# Get the start and end
my ($r0, $c0) = $p.positions[0]\ .list;
my ($re, $ce) = $p.positions[* - 1].list;
# Movements
my @movements;
{ # Move left
my $i = 1;
my $r = $r0 - $dr;
my $c = $c0 - $dc;
while self.pos-exists($r, $c) &&
self.pos-value($r, $c) ~~ any(0, $p.number) {
# Add
@movements.push(-$i);
# Next
++$i;
$r -= $dr;
$c -= $dc;
}
}
{ # Move right
my $i = 1;
my $r = $re + $dr;
my $c = $ce + $dc;
while self.pos-exists($r, $c) &&
self.pos-value($r, $c) ~~ any(0, $p.number) {
# Add
@movements.push($i);
# Next
++$i;
$r += $dr;
$c += $dc;
}
}
# Return the list of movements
return @movements;
}
# Move a piece
method move-piece(Piece $p, Int $dist) {
# Get the direction
my $dr = %grooves{$p.groove}[2];
my $dc = %grooves{$p.groove}[3];
# New
my $new-board = Board.new(rows => (@.rows.map: { [ .clone ] }),
pieces => @.pieces,
bullet => $.bullet);
# Remove
$new-board.reset-pos(|$_) for $p.positions;
# New positions
my @new-pos = $p.positions.map: { [ .list Z+ ($dist <<*>> ($dr, $dc)) ] };
# Set
$new-board.set-pos(|$_, $p.number) for @new-pos;
# New piece
my $new-piece = Piece.new(number => $p.number,
groove => $p.groove,
start => $p.start + $dist,
end => $p.end + $dist,
positions => @new-pos);
# Update
$new-board.pieces[$p.number - 1] = $new-piece;
$new-board.bullet = $new-piece if $.bullet === $p;
# Return the new board
return $new-board;
}
# Heuristic cost for A*
# It is an optimistic heuristic
method heuristic-cost() {
# Ending column of bullet
my $ce = $.bullet.positions[* - 1][1];
# There?
if $ce == 10 {
return 0;
}
else {
# The heuristic is the number of pieces between the end and the target
return
(($ce + 2, $ce + 4 ... 10).grep: { self.pos-value(3, $_) != 0 }).elems;
}
}
}
# Read board
sub read-board($input) is export {
# Create a Board
my Board $b = Board.new;
$b.make-empty;
# For each line
for $input.lines -> $line {
$line ~~ /^\s* (<[a .. w]>) (\d) (\d*) (\d) \s*$/ or
die "Bad input line: $line";
# Get
my ($groove, $start, $mid, $end) = (~$0, +$1, ~$2, +$3);
# Check mid is range
die "Bad input line: $line" if ($start + 1 .. $end - 1).join ne $mid;
# Add the piece
$b.add-piece($groove, $start, $end);
}
# Does it have a bullet
die "No bullet specified" unless $b.bullet.defined;
# Return it
return $b;
}
Heap.pm6:
# -*- mode: cperl6; -*-
# 2011 Perl 6 Coding Contest
# Edgar Gonzàlez i Pellicer
# Heap
module Heap;
# Min heap
class MinHeap is export {
has Pair @!data;
# Empty?
method empty() {
return !@!data;
}
# Size
method size() {
return @!data.elems;
}
# Top
method top() {
if @!data {
return @!data[0];
}
else {
return;
}
}
# Pop
method pop() {
# Which is the size
given +@!data {
# Empty
when 0 {
# Nothing
}
# One element
when 1 {
# Just remove it
pop(@!data);
}
# More
default {
# Take the last, and move it to the head
@!data[0] = pop(@!data);
# Position and children
my $p = 0;
my $l = 1;
my $r = 2;
# Sink it
while $l < @!data {
if $r < @!data {
# Two children
if @!data[$p].key > @!data[$l].key ||
@!data[$p].key > @!data[$r].key {
# Must sink
if @!data[$l].key < @!data[$r].key {
# Float left
@!data[$p, $l] = @!data[$l, $p];
$p = $l;
}
else {
# Float right
@!data[$p, $r] = @!data[$r, $p];
$p = $r;
}
}
else {
# Stop
last;
}
}
else {
# One child ($l)
if @!data[$p].key > @!data[$l].key {
# Must sink -> Float left
@!data[$p, $l] = @!data[$l, $p];
$p = $l;
}
else {
# Stop
last;
}
}
# Next children
$l = 2 * $p + 1;
$r = $l + 1;
}
}
}
# OK
return;
}
# Push
method push(Int $key, $value) {
# Add it
@!data.push(($key => $value));
# Position
my $p = @!data.elems - 1;
# Float it
while $p > 0 {
# Parent
my $pp = $p div 2;
if @!data[$pp].key > @!data[$p].key {
# Float
@!data[$p, $pp] = @!data[$pp, $p];
$p = $pp;
}
else {
# Stop
last;
}
}
# OK
return;
}
}
This solution makes an A star search on the graph of reachable board
configurations. It uses a MinHeap to efficiently emulate a priority queue for
what configuration to look at next.
The solution as sent in is incorrect. There's a call in Grooves.pm6 to
self.clear-pos, but such a method does not exist in that class. Curiously,
this causes Rakudo to abort, but everything works fine in Niecza.
For some reason, the program also emits "No bullet specified" at the end of each run, regardless of whether or not a bullet was specified.
There's a mix of tab characters and spaces used for indentation.
This solution introduces an internal representation of the positions of the board as being integer (row, col) tuples. The hexagonal aspect of it all is represented by the fact that rows with odd-valued columns and even-valued columns alternate.
This program is the fastest of the bunch, to the extent this can be measured reliably across all solutions running on either Rakudo or Niecza.
The code is definitely written in an object-y mindset, but it also makes use of
some features specific to Perl 6, such as hyperops and the %% operator.
Nope.