http://www.perlmonks.org?node_id=11128660


in reply to Challenge: Ricochet Robots

Sorry to be late,

it took me two days to write it

I kicked myself (very hard) into motion just yesterday, so I guess this solution still qualifies. It's same brute force, is definitely faster than choroba's and eats a little less RAM. Though tybalt89's uses impressively less memory, but with blue robot excluded from the fun, I don't know how to measure against it.

Edit: added readmore tag. Removed trailing space in one code line for better display in the node ("perfectionism"? never heard of that). Noticed, that lexical $x and $y in subroutine "shadow" variables with same names, used in same scope. Ugly, but won't fix it. Let it stay...

Edit2: There are strategies, obvious in hindsight, to slightly increase speed of solution below, by 2-3 seconds i.e. just ~5%, and significantly reduce RAM usage, by 20% or more. (1) Store @agenda items and %seen values not as 8 or 4 byte strings, but longlong and long integers, respectively -- i.e. add a few pack/unpack calls. (2) Even better, use $agenda scalar instead of @agenda array, then chop 8 bytes as $key from its start on each LOOP iteration, and append new 8 byte keys, when found, to its end. In latter case, RAM usage stays below 1 Gb.

Edit3: Actually, with $agenda as a single scalar, %seen values as integers, and, also, vec gone for good (i.e. substituted with substr/pack) -- solution below runs in ~32s (20% off) and eats ~805 Mb RAM.

Edit4 (25.02): Heh, if memory footprint (with speed still decent) is more important, and CPAN XS modules are OK, then ditch Perl hash (%seen) altogether, to track robots' positions explored so far. Math::GSL::SparseMatrix requires very minor changes to below source, and performance is ~57s and ~308 Mb. I'll post code if required. Concern may be, that hash keys could be any, but with 2D matrix we are limiting number of robots and/or playfield size, to be encoded into 128 bits only. Our current setup requires just 32 bits (though I'm using 64), so there's still plenty of address space. (The (1 x 256**8) sparse "matrix" was used, actually.)

Edit 26.02: Heh, further, using Judy leads to far better time/memory compromise balance. With tests now in Linux, the updated results (time(seconds)/memory(Megabytes)) with fixes according to edits 3 (Perl hash), 4 (Math::GSL) and this one (Judy) are 29/720, 48/310 and 35/162, respectively. Technology is amazing.

-----

Sorry, also, for shifts instead of multiplications and divisions, and extra parentheses because of this, but it shaves off a couple seconds. Code is (very) ugly, especially in prologue when the play-board is set up, but I haven't written anything in a few months, so that's what it leads to.

use strict; use warnings; use feature 'say'; use Time::HiRes 'time'; STDOUT-> autoflush( 1 ); my @lines = map { chomp; pack 'A80', $_ } <DATA>; my @even_lines = @lines[ grep !( $_ % 2 ), 2 .. $#lines - 2 ]; my @ROBOTS = qw/ Y R G B * /; # * IS NOT A ROBOT!!! my ( @x, @y ); # robots coordinates my $s = join '', @even_lines; for ( @ROBOTS ) { my $i = index $s, $_; push @x, $i % 80 / 4 - 1; push @y, int $i / 80; } my $TARGET_X = pop @x; # target position for 0th robot my $TARGET_Y = pop @y; # Transform playfield to lists of 16 rows and 16 columns. # They are 33 characters long strings. Walls (external and # internal) are a single "1" and are at even (counting from 0) # positions only. So first 3 rows (without robots) are # # 100000000010000000001000000000001 # 100010000000000000000000000010001 # 100000000000000000000010000000001 # # etc. Robot, if placed, sits on 3 characters (marking them as 1), # its center at odd position. Therefore, given a picture with # a placed robot, we can't tell if it's robot only or it touches # a wall. But it's OK because we won't "remove" robots # from (temporary) snapshots. my @rows = map { my $s = '0' x 33; my @a; push @a, pos while /\|/g; substr $s, ( $_ - 3 ) / 2, 1, 1 for @a; $s } @even_lines; my @cols = (( '0' x 33 ) x 16 ); for my $i ( 1 .. $#lines ) { next unless $i % 2; $_ = $lines[ $i ]; my @a; push @a, pos while /---/g; substr $cols[ ( $_ - 2 ) / 4 - 1 ], $i - 1, 1, 1 for @a; } my ( %seen, @agenda ); # Keys for %seen and items of @agenda are packed coordinates. # Hash values are packed move number, robot id, its previous # coordinates. my $key = pack 'C8', @x, @y; $seen { $key } = pack 'C4', 0, 0, 0, 0; push @agenda, $key; # Variables below (and $key above) are kept "global" to call a sub # without passing any arguments: # # robot id, move number, current coords, new position (either # x or y); offset is 0 when moving along row, 4 if along column my ( $r, $move, $x, $y, $newpos, $offset ); sub check_move { my $newkey = $key; vec( $newkey, $r + $offset, 8 ) = $newpos; return if exists $seen{ $newkey }; $seen{ $newkey } = pack 'C4', $move, $r, $x, $y; push @agenda, $newkey; return unless $r == 0; my ( $x, $y ) = unpack 'Cx3C', $newkey; return 1 if $x == $TARGET_X and $y == $TARGET_Y } my $t = time; my $n = 0; LOOP: while ( @agenda ) { $key = shift @agenda; $move = vec( $seen{ $key }, 0, 8 ) + 1; my @coords = unpack 'C8', $key; print '*' unless $n++ % 10000; # keep us entertained for ( 0 .. 3 ) { $r = $_; $x = $coords[ $r ]; $y = $coords[ $r + 4 ]; my $row = $rows[ $y ]; my $col = $cols[ $x ]; for my $other_r ( 0 .. 3 ) { # place other robots for # current move, if applicable next if $r == $other_r; substr $row, $coords[ $other_r ] << 1, 3, '111' if $y == $coords[ $other_r + 4 ]; substr $col, $coords[ $other_r + 4 ] << 1, 3, '111' if $x == $coords[ $other_r ]; } $offset = 0; ( $newpos = ( index( $row, '1', ( $x << 1 ) + 1 ) >> 1 ) - 1 ) != $x and check_move and last LOOP; ( $newpos = rindex( $row, '1', ( $x << 1 ) + 1 ) >> 1 ) != $x and check_move and last LOOP; $offset = 4; ( $newpos = ( index( $col, '1', ( $y << 1 ) + 1 ) >> 1 ) - 1 ) != $y and check_move and last LOOP; ( $newpos = rindex( $col, '1', ( $y << 1 ) + 1 ) >> 1 ) != $y and check_move and last LOOP; } } print "\n\n"; # Unwind moves, but because we are going backwards, # reverse order for final display. $key = $agenda[ -1 ]; my @moves; my @NUMBERS = ( 1 .. 16 ); my @LETTERS = ( 'A' .. 'P' ); while () { my @coords = unpack 'C8', $key; my ( $move, $r, $old_x, $old_y ) = unpack 'C4', $seen{ $key }; last if $move == 0; my ( $x, $y ) = @coords[ $r, $r + 4 ]; push @moves, "$ROBOTS[$r] moves from ". "$LETTERS[$old_x]$NUMBERS[$old_y] to ". "$LETTERS[$x]$NUMBERS[$y]"; vec( $key, $r, 8 ) = $old_x; vec( $key, $r + 4, 8 ) = $old_y; } say for reverse @moves; say "\nTime consumed: ", time - $t; __DATA__ A B C D E F G H I J K L M N O P --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- 1| | R | |1 . .---. . . . . . . . . . . .---. . 2| | | |2 . . . . . . . . . . . . . . . . 3| | |3 . . . . . . . . . . .---. . . . . 4| | |4 . . . . . .---. . . . . . . . .---. 5| |5 ---. . . .---. . . . . . . . . . . . 6| | |6 . . . . . . . . . . . . . . . . 7| | | |7 .---. . . . . .---.---. .---. . .---. . . 8| | | | |8 . . . . . . . . . . . . . . . . 9| * | | |9 . . . . . . .---.---. . . .---. . . . 10| | B | |10 . . . .---. .---. . . . . . . . .---. 11| | |11 ---. . . . . . . . . . . . . . . . 12| |12 . . . . . . .---. .---. . . . . . . 13| | | |13 .---. . . . . . . . . . . . . . . 14| (Y)| | |14 . . . . . . . . . . . . . .---. . 15| | | |15 . . .---. . . . . . . .---. . . . . 16| | G | |16 --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- A B C D E F G H I J K L M N O P

The output (stars skipped):

Y moves from B14 to A14 Y moves from A14 to A12 Y moves from A12 to P12 R moves from J1 to J12 R moves from J12 to A12 G moves from F16 to F1 G moves from F1 to J1 G moves from J1 to J12 G moves from J12 to B12 Y moves from P12 to C12 G moves from B12 to B8 R moves from A12 to B12 G moves from B8 to G8 R moves from B12 to B8 G moves from G8 to C8 Y moves from C12 to C9 Time consumed: 40.0800559520721

Thanks for distraction, I needed it :)