Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
 
PerlMonks  

Re: Challenge: Ricochet Robots

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


in reply to Challenge: Ricochet Robots

So, here are the moves:

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 (Cardinal) 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)

    > 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
Node Status?
node history
Node Type: note [id://11128553]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (9)
As of 2021-04-14 16:16 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?