Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

Advent of Code, Day 15, golfed!

by Jasper (Chaplain)
on Dec 17, 2021 at 17:32 UTC ( #11139690=obfuscated: print w/replies, xml ) Need Help??

I was doing the advent of code (https://adventofcode.com/2021/), until I got to day 16, started to read the instructions, got about a third of the way through, and decided that that was enough for the year! LOL

However, I really enjoyed day 15, on finding the score path of least resistance through something like

19999 19111 19191 19191 11191
which (being a non-computer scientist), started as a recursive path-finding algorigthm. That worked for tiny sample grids, but for bigger grids (the problem grid was 100x100), I needed to start being clever, so I started remembering the lowest score to a position, and then if I came across that position again with a lower score, I could say, oh, now the score from there can now be this. Then I realised I'd have to start adjusting scores for every point I'd ever moved to (etc.) any previous time I'd been to that point and that became an absolute nightmare. I eventually ended up googling shortest path algorithms, and implementing Dijkstra's shortest path method.

Then the golfing started :) I've ended up with this:

# run with perl -ln prog.pl input push@a,/./g;$r||=@a}{print$s{-1+map{$u{$_}||=$a[$_]+$s{$g-1}for grep$a[$_]*!$s{$_},$g+$r,$g-!!($g%$r),$g-$r*($g>=$r),++$g*!!($g %$r);($g)=sort{$u{$a}-$u{$b}}keys%u;$s{$g}=delete$u{$g}}@a}

So, the idea is to enter the maze at the top left and work out what the score of the path is (with no diagonal moves) ending up bottom right. The input is always a square in AoC/2021/15.

Dijkstra's algorithm says put the starting position in your tree set (%s) with a score, then add the positions (and the aggregate scores) you can move to the unused set (%u), choose from unused the position with the lowest aggregate score, delete that from unused, add it to the tree set. From that new position, calculate the scores of the positions you can move to from there and continue.

Here's my golfed solution blown up:

1 push @a,/./g; 2 $r||=@a 3 }{ 4 print $s{ 5 -1 + map{ 6 $u{$_}||=$a[$_]+$s{$g-1} for 7 grep $a[$_] * !$s{$_}, 8 $g+$r, 9 $g-!!($g%$r), 10 $g-$r*($g>=$r), 11 ++$g*!!($g %$r); 12 ($g)=sort{$u{$a}-$u{$b}}keys%u; 13 $s{$g}=delete$u{$g} 14 }@a 15 }

The }{ at line 3 means (when you run with perl -ln) that the lines above are run on each line of input (with the input as $_) and those below are run after all the input has been read.

So,

line 1 when the input is read, I'm filling @a with each digit in the maze. It's a single digit array, so I have to be a little bit cleverer later when working out what "coordinates" I can move to from the current position.

Line 2 I'm taking the width of the grid, and the ||= just means don't overwrite this when reading input lines 2, 3, 4... or you'd be remembering it wrong!

Lines 5-14 is the meat of the map loop, over @a. As I said above, for Dijkstra's algorithm you choose an unused position from your grid and move it into the tree set on each loop, so mapping over @a gives us enought loops to score the entire grid.

Line 6-11 is finding the next possible moves, and putting them into the unused hash %u, with a score.

$g is the current position, $r is the width of the grid, so on lines 8-11 are the possible moves:

move down $g+$r - if we're on the last row, $a[$g+$r] is out of range and 0, the grep on line 7 filters it out,
move left $g-!!($g%$r) - so $g-1 if $p%$r (i.e. we're not in the first column) otherwise $g, and because $s{$g} exists (that's the position we're in currently), that won't pass through the grep
move up $g-$r*($g>=$r)<code/> if we are on row two or more, <code>$g>=$r is true (1), so we pass through $g-$r*1, otherwise $g-$r*0 ($g, which gets filtered)
move right ++$g*!!($g %$r) - which is ($g+1)*!!(($g+1)%r) with a lot less bracketing - checking if we're in the rightmost column, and passing $g+1 or $g.

Those 4 positions get filtered by $a[$_] * !$s{$_} - i.e. is this a valid position with a score in the grid (luckily 0 wasn't a valid score in this AoC), and it hasn't already been put in the set %s.

Line 6 - So now we have valid, unused position, we score them, and assign them to the unused hash %s: $a[$_] is the score of the position, and $s[$g-1] is the score of the current position (we did ++$g in line 11, remember, so we have to subtract 1. The ||= we have, because you can move to all positions from more than one place, so we've possibly seen this location before, and if we have seen it before, it had a lower score (or the same score) last time.

So now we have added some more unused possibles positions, and the scores to get there, to the %u hash, in line 12 we choose the lowest scoring one of those, and in line 13 we remove it from %u, and put it in %s.

Actually, the first time we go through this loop, $g is undef. Dijkstra says you should assign the starting position to %s at the beginning, but it turns out we don't need to do that explicitly. Since we start with undef, 0 for $a[$g] purposes, in the top left, means that $g-!!($g%$r) gets passed through, so 0 and a score (not the right score for starting at 0, but who cares, this is golf) will eventually get assigned to %s.

At this stage, we have done the whole loop, so we finish with the print $s{-1+ map{...} @a  }, sort of equivalent to $s{$#a}, the path score of the last element of @a.

And that's that. Hope that was clear enough! Hope those of you who are continuing with Advent of Code are still enjoying it. Merry Christmas!

Replies are listed 'Best First'.
Re: Advent of Code, Day 15, golfed!
by tybalt89 (Monsignor) on Dec 18, 2021 at 02:44 UTC

    Quick golf trick: push() has a return value :)
    Replace push@a,/./g;$r||=@a with $r||=push@a,/./g and save 3 strokes.

    UPDATE: Oops. that what I get for not testing :(

    Alternates:

    push@a,@r=/./g}{print$s{-1+map{$u{$_}||=$a[$_]+$s{$g-1}for grep$a[$_]*!$s{$_},$g+@r,$g-!!($g%@r),$g-@r*($g>=@r),++$g*!!($g %@r);($g)=sort{$u{$a}-$u{$b}}keys%u;$s{$g}=delete$u{$g}}@a}

    and

    # problem description says "resembles a square" push@a,/./g}{print$s{-1+map{$u{$_}||=$a[$_]+$s{$g-1}for grep$a[$_]*!$s{$_},$g+$.,$g-!!($g%$.),$g-$.*($g>=$.),++$g*!!($g %$.);($g)=sort{$u{$a}-$u{$b}}keys%u;$s{$g}=delete$u{$g}}@a}
      I don't think that will work because only the first row will be pushed into @a.
      Combining that with another stroke saved by replacing the stupid ++$g, $g-1 stuff
      push@a,/./g}{print$s{-1+map{$u{$_}||=$a[$_]+$s{$g}for grep$a[$_]*!$s{$_},$g+$.,$g-($g%$.>0),$g-$.*($g>=$.),$g+($g%$. <$.-1);($g)=sort{$u{$a}-$u{$b}}keys%u;$s{$g}=delete$u{$g}}@a}
      $. definitely works, how could I forget! :)

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (4)
As of 2022-11-30 00:56 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Notices?