in reply to Challenge: Ricochet Robots
So, here are the moves:
1:Y A14
2:Y A12
3:Y P12
4:R J12
5:G F1
6:G J1
7:R A12
8:G J12
9:G B12
10:Y C12
11:G B8
12:G G8
13:R B12
14:R B8
15:G C8
16:Y C9
And here's how to get them (they're printed in reversed order). The code is ugly, but works:
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use constant WIDTH => 16;
sub char { chr $_[0] + ord '@' }
sub num { ord($_[0]) - ord '@' }
my @BELOW = qw( A5 A11 B7 B13 C1 D15 E5 E10 G4 G10 H7 H9
H12 I7 I9 J12 K7 L3 L15 M9 N7 O1 O14 P4 P10 );
my @RIGHT = qw( B2 B7 B14 D10 D15 E1 E6 E16 F4 F11 G8 G9
H13 I8 I9 I13 J1 K3 K8 L15 M10 N2 N7 N14 N16 );
my %BLOCKED;
@{ $BLOCKED{BELOW} }{@BELOW} = ();
@{ $BLOCKED{RIGHT} }{@RIGHT} = ();
my @DIRECTIONS = ([0, 1], [1, 0], [0, -1], [-1, 0]); # down, right, u
+p, left.
my %access;
for my $column (1 .. WIDTH) {
for my $row (1 .. WIDTH) {
for my $direction (@DIRECTIONS) {
my ($target_row, $target_column) = ($row, $column);
while (1) {
my $column_correction = $direction->[0] > -1 ? 0 : -1;
my $row_correction = $direction->[1] > -1 ? 0 : -1;
my $check = (char($target_column + $column_correction)
+)
. ($target_row + $row_correction);
last if exists $BLOCKED{
$direction->[0] ? 'RIGHT' : 'BELOW'}{$check};
my $next_row = $target_row + $direction->[1];
my $next_column = $target_column + $direction->[0];
my $moving = $direction->[0] ? $next_column : $next_ro
+w;
last if $moving < 1 || $moving > WIDTH;
$target_row = $next_row;
$target_column = $next_column;
}
undef $access{$column}{$row}{$target_column}{$target_row}
unless $column == $target_column && $row == $target_ro
+w;
}
}
}
my %robot = (R => [num('J'), 1],
G => [num('F'), 16],
B => [num('M'), 10],
Y => [num('B'), 14]);
sub config { pack 'C8', map @$_, @robot{qw{ R G B Y }} }
sub setup {
@robot{qw{ R G B Y }} = map [ unpack 'C2', pack S => $_ ], unpack
+'S4', $_[0];
}
my $config = config();
my %previous = ($config => 1);
my %seen = ($config => 0);
my @goal = (num('C'), 9);
my $step = 1;
SOLVE:
while (1) {
for my $config (keys %seen) {
next unless $seen{$config} == $step - 1;
setup($config);
for my $robot (keys %robot) {
for my $target_column (keys %{ $access{ $robot{$robot}[0]
+}
{ $robot{$robot}[1]
+} }
) {
for my $target_row (keys %{ $access{ $robot{$robot}[0]
+ }
{ $robot{$robot}[1]
+ }
{$target_column} }
) {
my ($robot_column, $robot_row) = @{ $robot{$robot}
+ };
for my $other (grep $_ ne $robot, keys %robot) {
my ($other_column, $other_row) = @{ $robot{$ot
+her} };
if ($robot_column == $target_column
&& $robot_column == $other_column
) {
if ($robot_row < $other_row && $other_row
+<= $target_row) {
$target_row = $other_row - 1;
} elsif ($robot_row > $other_row && $other
+_row >= $target_row) {
$target_row = $other_row + 1;
}
} elsif ($robot_row == $target_row
&& $robot_row == $other_row
) {
if ($robot_column < $other_column && $othe
+r_column <= $target_column) {
$target_column = $other_column - 1;
} elsif ($robot_column > $other_column &&
+$other_column >= $target_column) {
$target_column = $other_column + 1;
}
}
}
{ local $robot{$robot} = [$target_column, $targe
+t_row];
if ('Y' eq $robot && $robot{Y}[0] == $goal[0]
&& $robot{Y}[1] == $goal[1]
) {
say "DONE $step";
my $c = $config;
my %robot_previous = %robot;
while ($c) {
for my $r (keys %robot) {
say "$r: ", char($robot_previous{$
+r}[0]), $robot_previous{$r}[1]
unless "@{ $robot_previous{$r}
+ }" eq "@{ $robot{$r} }";
}
%robot_previous = %robot;
setup($c);
$c = $previous{$c};
}
last SOLVE
}
my $next = config();
next if exists $seen{$next};
$seen{$next} = $step;
$previous{$next} = $config;
}
}
}
}
}
++$step;
}
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
Re^2: Challenge: Ricochet Robots
by LanX (Saint) on Feb 19, 2021 at 12:57 UTC
|
Yep you solved it and it took 6 min on my machine
here a (handmade) visualization from my solutions (some steps are in another order)
A B C D E F G H I J K L M N O P
--- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
1| | g6 g(R)| |1
. .---. . . . . . . . . . . .---. .
2| | | |2
. . . . . . . . . . . . . . . .
3| | |3
. . . . . . . . . . .---. . . . .
4| | |4
. . . . . .---. . . . . . . . .---.
5| |5
---. . . .---. . . . . . . . . . . .
6| | |6
. . . . . . . . . . . . . . . .
7| | | |7
.---. . . . . .---.---. .---. . .---. . .
8| R14 g15 g12| | | |8
. . . . . . . . . . . . . . . .
9| Y16 | | |9
. . . . . . .---.---. . . .---. . . .
10| | B | |10
. . . .---. .---. . . . . . . . .---.
11| | |11
---. . . . . . . . . . . . . . . .
12| r5 g9 y10 gr y3 |12
. . . . . . .---. .---. . . . . . .
13| | | |13
.---. . . . . . . . . . . . . . .
14| y1 (Y)| | |14
. . . . . . . . . . . . . .---. .
15| | | |15
. . .---. . . . . . . .---. . . . .
16| |(G) | |16
--- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
A B C D E F G H I J K L M N O P
> The code is ugly, but works:
well mine is uglier (but I was at the start of my Perl career ;-)
I didn't analyze your code yet.
But I think yours is swapping much less than mine.°
Want a harder challenge? =)
PS: did you have fun? :)
UPDATE
°) nope, you need 2GB RAM mine only 0.5GB | [reply] [d/l] |
|
> Want a harder challenge?
Rather not. This was still manageable, but a harder one would be less fun. I have enough of them at work.
> did you have fun?
Yes, especially when I finished it! ;-)
> you need 2GB RAM
The original version that didn't produce the moves was less memory hungry. But the initial solution that stored the configuration as a string ate all my machine's memory and wasn't able to finish, so I had to introduce pack to make it more compact. I'd be interested in seeing an alternative solution.
map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
| [reply] [d/l] |
|
> > did you have fun?
> Yes, especially when I finished it! ;-)
Oh, at 3 am? Did it wake up your wife? ;-)
> I have enough of them at work.
Yeah me too.
> I'd be interested in seeing an alternative solution.
Don't wanna spoil the fun here. :)
FWIW found a presentation in the internet from 2012 using most of the same principles though.
| [reply] |
|
|