Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Re: Challenge: Ricochet Robots

by choroba (Cardinal)
on Feb 19, 2021 at 09:30 UTC ( [id://11128553]=note: print w/replies, xml ) Need Help??


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]

Replies are listed 'Best First'.
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? =)

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

    PS: did you have fun? :)

    UPDATE

    °) nope, you need 2GB RAM mine only 0.5GB

      > 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]
        > > 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.

        Cheers Rolf
        (addicted to the Perl Programming Language :)
        Wikisyntax for the Monastery

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: note [id://11128553]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others pondering the Monastery: (3)
As of 2024-04-25 23:39 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found