RL

AAA = (BBB, CCC)
BBB = (DDD, EEE)
CCC = (ZZZ, GGG)
DDD = (DDD, DDD)
EEE = (EEE, EEE)
GGG = (GGG, GGG)
ZZZ = (ZZZ, ZZZ)


All one need do is make a hash of the nodes with their branches, then dance through it.

my %index = ( L => 0, R => 1 );

The dance moves are specified as L or R and for no particular reason I decided to save the branches as arrays instead of hashes, so I prepare to translate dance moves into array indices. Why on earth did I call this %index instead of %dirindex or %dir? Because I had just woken up and it was time to do AoC? Probably.

$_ = <>; chomp;
my @instr = map { $index{$_} } split(//);

<>;


I grab the dance moves, translate them from directions to indices, and toss the following blank line.

my %map;
while (<>) {
my ($node, $l, $r) = /(\w{3})/g;
$map{$node} = [ $l, $r ];
}


Then read in and save all the nodes.

my $count = 0;
my $pos = "AAA";

until ($count % @instr == 0 && $pos eq "ZZZ") {
$pos = $map{$pos}[$instr[$count++ % @instr]];
}


Finally, start at AAA; take steps, counting as I go (and using the modulus of the number of dance moves in the pattern); and stop at ZZZ only if it's the end of this dance pattern.

Full Program

#!/usr/bin/perl

print "$count steps\n";


my $cardlist = "AKQT98765432J";

Change the card sort order;

my $jokers = grep { $_ eq "J" } @cards;

count the jokers;

++ $tally{$_} foreach grep { $_ ne "J" } @cards;

omit the jokers when counting cards for type of hand;

$ofakind[0] += $jokers;

and in this poker variant, simply add the count of jokers to the count of the most-frequent card when determining type of hand.

Full Program

#!/usr/bin/perl

sub cardval {
my $c = shift;
my $cardlist = "AKQT98765432J";
return length($cardlist) - index($cardlist, $c);
}


32T3K 765
T55J5 684
KK677 28
KTJJT 220
QQQJA 483


This sort is going to require a fair number of comparisons, each involving rank of types of hands and each potentially involving rank of cards. These comparisons are computationally-intensive enough that I’m leery about executing them during each comparison of the sort, so I calculated and cached them up front.

sub cardval {
my $c = shift;
my $cardlist = "AKQJT98765432";
return length($cardlist) - index($cardlist, $c);
}


The card’s rank can be represented as its (here 0-based) ordinal position in an ascending-order list of ranks. I had a descending-order list and subtracted the position in the string from the length of the string; but doing this again, I’d use Perl’s reverse operator to reverse the string.

$cardlist is constant and it would be more efficient to declare it once outside the subroutine than each time the subroutine is called. I’d love to define it immediately before the subroutine definition, but that code won’t have been executed yet when the subroutine is called. I could have defined it at the top of the program but I don’t like separating it so far from its sole use in the code. I don’t know whether Perl has developed a better way to handle this situation.

while (<>) {
my ($cards, $bid) = /(\w+)/g;
my @cards = split(//, $cards);
my @values = map { cardval($_) } @cards;


Reading in the hands, I grab the two chunks of “word” characters, split the card string into a list, and use Perl’s map operator to translate the list of cards into a list of their values/ranks.

my %tally;
++ $tally{$_} foreach @cards;
my @ofakind = sort { $b <=> $a } values %tally;
my $type = $ofakind[0] == 5 ? 6 # 5 of kind -- 6
: $ofakind[0] == 4 ? 5 # 4 of kind -- 5
: $ofakind[0] == 3 && $ofakind[1] == 2 ? 4 # full house -- 4
: $ofakind[0] == 3 ? 3 # 3 of kind -- 3
: $ofakind[0] == 2 && $ofakind[1] == 2 ? 2 # 2 pair -- 2
: $ofakind[0] == 2 ? 1 # 1 pair -- 1
: 0; # nothing -- 0


Then I count how many of each rank of card I have in this hand and sort that list of counts into descending order. From the number of cards that I have the most of, and sometimes the second-most of, I can determine the type of the hand; and I assign a numerical score to each type.

When we have three or two of the most-frequent card, there are two possible types of hands depending on whether the remaining cards contain a pair. I could have written those four cases as two outer ternaries each with an inner ternary; but for ease of reading (and I assure you my code is nicely tabbed and aligned when you’re not looking at it in WordPress), I didn’t mind the expense of rechecking the count of the most-frequent card in order to write the code for every type of hand the same way.

push(@hands, { CARDS => [ @cards ], BID => $bid, VALUES => [ @values ],
TYPE => $type });
}


I’ve now precalculated everything that I wanted to cache before the sort and I hang onto it in a list of references to anonymous hashes, which function like a C struct, with the hash key being the struct member.

I don’t actually need the cards any more, but cached them in case I wanted them later for debugging.

my @sortedhands = sort { ${$a}{TYPE} <=> ${$b}{TYPE}
|| ${$a}{VALUES}[0] <=> ${$b}{VALUES}[0]
|| ${$a}{VALUES}[1] <=> ${$b}{VALUES}[1]
|| ${$a}{VALUES}[2] <=> ${$b}{VALUES}[2]
|| ${$a}{VALUES}[3] <=> ${$b}{VALUES}[3]
|| ${$a}{VALUES}[4] <=> ${$b}{VALUES}[4]
} @hands;


With all that cached, the sort itself is easy. Note that Perl uses the special variables $a and $b for the comparands in each sort comparison; and since we’re sorting a list of hash references, $a and $b do need to be dereferenced.

my $sum;
$sum += ($_ + 1) * $sortedhands[$_]{BID} foreach (0 .. scalar @sortedhands - 1);
print "sum is $sum\n";


With the hands sorted, calculating the requested sum is easy.

Full Program

#!/usr/bin/perl

sub cardval {
my $c = shift;
my $cardlist = "AKQJT98765432";
return length($cardlist) - index($cardlist, $c);
}


The distance traveled is (ignoring units) t_charge ( t_total – t_charge); so the answer to the problem can be found directly by using your favorite quadratic solver on t_charge² – t_total t_charge + d_record = 0, which will have zero, one, or two real solutions. If it has zero solutions, one solution that’s non-integer, or two non-integer solutions between two consecutive integers, then there are zero integer charge times that beat the record. Otherwise count the number of integers from the floor of the lower solution plus one to the ceiling of the upper minus one. (That sounds weird but math it out — it ensures not merely tying the record but beating it.)

Anyone who remembers algebra and has dignity and self-respect would use this trivial approach.

I wrote a program to count winning charge times by iteration.

my $count = grep { $_ * ($t - $_) > $d } (1 .. $t - 1);

All of the Perl syntax in this program, I’ve already used this year, so there’s nothing new to explain. The only thing that seems worth calling out is that finding “qualifying” members of a list, or even of a small range of numbers, is very conveniently done with grep.

Part 2 says that the columns of numbers in the input don’t represent separate races; the spaces between them were unintentional and the digits should be run together into larger numbers. Having already written this in part 1:

@time = /(\d+)/g if /Time/;
@dist = /(\d+)/g if /Dist/;


it was the pinnacle of laziness efficiency to reuse that digit extraction and join the results together:

$t = join("", /(\d+)/g) if /Time/;
$d = join("", /(\d+)/g) if /Dist/;


But one could also use s/[^\d]+//g to delete everything that’s not a digit, if that’s what floats your boat.

Full Part 1 Program

#!/usr/bin/perl

print "product $prod\n";


Full Part 2 Program

#!/usr/bin/perl

print "count $count\n";


After the way I wrote the first program, this made me feel like Obi-Wan just told me to go home and rethink my life. I could enumerate each range of seeds and run them all through the translations … for certain values of “could” that include more processing power, electricity, and time than I have remaining in my years on this planet.

It was obvious that I was going to have to treat ranges as data structures, intersect them with ranges in translation rules, translate them accordingly, and be prepared to split seed ranges that overlapped translation ranges to apply the translation to only a portion of the input range. Afflicted with a serious case of I don’t wanna, I pretended to be too busy with other things to get around to writing this yesterday.

But early this morning I cured my case of I don’t wanna in the way I’ve learned to cure any case related to programming: Write the utilitarian loops that do the boring work of the program; and once they’re done, there’s so little of the program left to write that I’m ready to go ahead and do it.

20231207 edit: I omitted handling one way that intervals can intersect and it was accidental that my program handles that case correctly. More below.

Read the Seed Ranges

In part 1, I iterated through seeds, applying consecutive translations to each. For part 2, I iterate through mapping tables, applying each to all seed ranges / translated seed ranges.

$_ = <>;
chomp;
my @ranges = /(\d+)/g if /^seeds/;


So start by grabbing all of the seed ranges. Don’t bother parsing them into (start, length) pairs yet.

Read a Translation Map

# Loop through mapping rules, applying each to our list of seed ranges.
while (<>) {
# Parse the map, saving destination, start, length, end, and offset.
my @map;
foreach (grep { ! /map/ } split /\n/) {
my @n = split /\s+/;
push @map, { D => $n[0], S => $n[1], L => $n[2],
E => $n[1] + $n[2] - 1, O => $n[0] - $n[1] };
}


Each remaining input record is a translation map. I totes forgot to chomp here and I suspect that split on whitespace (A) matches newlines as whitespace and (B) discards empty trailing fields, but don’t quote me on that without you test it yourself first.

So … split the paragraph into individual lines. Discard the line that has map in it. For the remaining lines, split into whitespace-delimited fields. Create an anonymous hash and push its reference onto the array of this map. I went all out here and precomputed every value I thought I might want later, stuffing them all into the hash: Dest, Source, and Length were provided; and I also calculated End and Offset here because I was going to use them multiple times later and because I was more likely to write an off-by-one error later than when I was paying attention here.

Checking Current Range for Translation Intersection

# Apply this transformation to our list of number ranges,
# building a list of resulting number ranges.
my @newranges;
range: while (@ranges) {
my $s = shift @ranges; my $l = shift @ranges; my $e = $s + $l - 1;


For this set of map rules, loop through all of our current set of ranges of interest. Within each, break out the (start, length) pair and for convenience, also calculate the end of the range.

# Check whether the current range intersects any map range.
maprule: foreach my $href (@map) {
# If this range doesn't intersect this map rule, try the next.
next maprule if $e < $$href{S} || $$href{E} < $s;


Loop through the mapping rules. For each, first check whether the current range of interest doesn't even intersect with the range of this map rule -- the end of the range of interest is less than the start of the map range, or the end of the map range is less than the start of the range of interest. If no intersection with this map rule, go on and try the next.

# If this range is completely enclosed in this map rule, apply.
if ($$href{S} <= $s && $e <= $$href{E}) {
$s += $$href{O};
push(@newranges, $s, $l);
next range;
}


Maybe this range of interest is a subset of the range of the map rule? If so, apply the map rule's translation (offset) to the start of the range, then push the translated (start, length) pair onto the list of new ranges to be used in the next mapping, and move on to the next range of interest.

# This range intersects but is not fully enclosed in
# this map rule. Split, apply the transformation to the
# intersection, and push the leftover back onto this pass.
if ($s < $$href{S}) { # overlaps start of map rule
my $s1 = $s;
my $e1 = $$href{S} - 1;
my $l1 = $e1 - $s1 + 1;
unshift(@ranges, $s1, $l1);

next range;


If we've fallen through the logic to this point, then the range of interest does overlaps this mapping rule's range (and is not simply a subset). Does the range of interest overlap the beginning of the map rule (or the end)?

Either way, break this range of interest into two ranges of interest. In the case of overlapping the beginning of the map range, the first new range of interest is passed back into the list of ranges for the current round (because another map rule might apply to it) with no translation and the second is passed forward for the next round with this translation rule's offset applied. Clearly all of this could have been written in a single line; but breaking it out into variables makes it very clear what I'm doing, is easier for me to avoid more off-by-one errors, costs me next to nothing, and is probably even optimized away.

unshift pushes values onto the beginning of a list (array); push pushes values onto the end. I'm putting the unprocessed leftovers from this cut back onto the beginning of the current list and the translated range from this cut onto the end of next time's list.

And then move on to the next range of interest.

The code for a range of interest that overlaps the end of this mapping rule's range is very similar.

20231207 edit: As I was drafting notes about intervals in preparation for programming, I included the case where a map rule range was completely enclosed within a range of interest, splitting the range of interest into three intervals; but I forgot about that when coding.

Very lucky and very sloppy.

# No intersection, so current range is untouched.
push(@newranges, $s, $l);
}

# Save the resulting list of ranges for next time.
@ranges = @newranges;


If we fall through the loop of testing all of the mapping rules without having matched one and nexted on to the next range of interest, then this range of interest has no translation in this map and is preserved intact for the next round.

Find the Minimum Translated Value

# Find the minimum range start after all processing.
my $min;
while (@ranges) {
my $s = shift @ranges; shift @ranges;
$min = $s if !defined $min || $s < $min;
}


In my approach to part 1, the minimum was captured as a running value along the way; but in part 2, I need to go back and find it myself.

@ranges is (still) an unstructured list of (start, length) pairs and I don't remember if there's a cool-kid way to select alternating values from a list; so I iterate through the list, looking for the minimum range start (which will be the lowest value in any range).

Full Program

#!/usr/bin/perl

print "\nminimum location $min\n";


seeds: 79 14 55 13

...


I went over the top on this problem, loading all of the translations into memory as though they were important, then iterated through seeds in my outer loop and translations looping inside that on each seed.

Parsing the File

sub getinput {
$/ = "\n\n";

while (<>) {
chomp;


$/ is Perl’s input record separator, newline by default. If you set it to something else, each read of a record (line) of input will be separated/ terminated by this record separator. I set it to two newlines to grab a paragraph of input at a time. Then chomp is aware and discards the trailing input record separator (the trailing pair of newlines, not just the last trailing newline).

@seed = /(\d+)/g, next if /^seeds/;

Perl’s regular expression operators work fine on multi-line strings (and have some special modifiers available that I don’t need here). So this line watches for the input paragraph that begins with seeds, grabs ( ) strings of digits \d+ out of it, all of them /g, returns that list, and stores it in the array @seed.

s/(\S+)\s+map:\n//; my $which = $1;
foreach (split /\n/) {
my @n = split /\s+/;
push @{$map{$which}}, { D => $n[0], S => $n[1], L => $n[2] };
}


If a paragraph starts with some kind of map, delete that line of the paragraph, grabbing the map name out of it along the way. Then split the rest of the paragraph into lines; split each line on whitespace (also could have done my @n = /(\d+)/g again but I’m fickle); and treat the %map hash element keyed by $which as an array, pushing an anonymous hash { } onto it keyed mnemonically by Dest, Source, and Length, allowing rapid retrieval of these values later by symbol rather than merely by ordinal position as they were given to us in the puzzle input.

Mapping Values by Range Translations

sub mapval {
my ($src, $lref) = @_;


I want to call this subroutine with parameters: a source (seed) value and an array (list) reference to a set of range translations. Subroutine parameters arrive in the special array @_, so break them out to variables with (vaguely) meaningful names.

my $mapped;
foreach my $href (@$lref) {
$mapped = $$href{D} - $$href{S} + $src
if $src >= $$href{S} && $src <= $$href{S} + $$href{L} - 1;
}


Go through the list @$lref of range translations pointed at by the array reference, each of which is a hash reference. If our seed value is within the range (between $$href{S} and $$href{S} + $$href{L} - 1), then map it by applying the offset between the translation's destination and source.

One could do a last here to avoid testing further translations; but there aren't many per map and each seed will only match one translation per map; so I didn't bother and let it cycle through testing the remaining ranges.

return $mapped || $src;

If we applied a translation, return that, otherwise return the seed value.

Clumsily Calling It All

my $min;
foreach my $seed (@seed) {
my $soil = mapval($seed, $map{"seed-to-soil"});
my $fert = mapval($soil, $map{"soil-to-fertilizer"});
my $water = mapval($fert, $map{"fertilizer-to-water"});
my $light = mapval($water, $map{"water-to-light"});
my $temp = mapval($light, $map{"light-to-temperature"});
my $humid = mapval($temp, $map{"temperature-to-humidity"});
my $loc = mapval($humid, $map{"humidity-to-location"});


Since I'm never going to need these maps again, this was an oddly careful way of setting them up and using them.

I could of course have written this as a deeply-nested series of subroutine calls instead of sequentially capturing all of the intermediate values; but I was expecting to have to debug this (didn't) and wanted the intermediate values at hand for inspection.

Full Program

#!/usr/bin/perl

#print "$src:\t", $mapped ? $mapped : "unmapped", "\n";
return $mapped || $src;
}


It would be vaguely entertaining to implement this using a queue of the coefficients of upcoming lines, or using recursion; but I chose simply to build an array of the multipliers that I prepopulate for lines I haven’t seen yet.

my $wins = grep { my $num = $_; grep { $_ == $num } @winning }
split(/\s+/, $mine);


The program begins the same as part 1; but instead of advancing the value of the wins by a particular algorithm, simply capture the count of winning numbers.

# Add the physical instance of this card to however many we've earned.
my $instances = ++ $cards[$. - 1];
$total += $instances;


However many duplicates of this row/card have been earned by previous results, increment it by one for this actual row; set that as the number of instances of this row; and add that to the total instances for the puzzle answer.

# If this was a winner, clone future cards.
if ($wins) {
$cards[$_] += $instances foreach ($. .. $. + $wins - 1);
}


If we had any winners, then add the number of instances of the current card to the instance count of the appropriate next few cards.

( num .. num ) is a Perl range operator that generates a list of values counting from the lower to the upper. (Use with caution on potentially-large lists, though this may have been optimized.) $. is the current line number of the input but it’s 1-based and Perl’s array is 0-based. So the current line of input $. is in array element $. - 1; therefore array element $. holds the number of (extra) instances of the next line of input and element $. + $wins - 1 holds the number of (extra) instances of $wins rows after the current.

Full Program

#!/usr/bin/perl

print "total: $total\n";


Card 1: 41 48 83 86 17 | 83 86 6 31 17 9 48 53
Card 2: 13 32 20 16 61 | 61 30 68 82 17 32 24 19
Card 3: 1 21 53 59 44 | 69 82 63 72 16 21 14 1
Card 4: 41 92 73 84 69 | 59 84 76 51 58 5 54 83
Card 5: 87 83 26 28 32 | 88 30 70 12 93 22 82 36
Card 6: 31 18 13 56 72 | 74 77 10 23 35 67 36 11


O’Reilly’s Perl Cookbook has concise code for finding the union and intersection of two lists, but it requires that each list has unduplicated entries. I suspect that’s going to be the case here but I’m not sure I should presume, so I’ll do my own thing.

my $numlistre = qr/(?:\d+\s+)*\d+/;

Each line of input has two lists of numbers on it that I’ll want to capture when parsing the line; and I could write the regular expression for capturing a list of numbers twice; but instead I’ll write it once (outside the loop, for efficiency) and put it in a variable.

This is zero or more sets of ( one or more digits followed by one or more spaces ) and then one more set of digits. To repeat * the digits-and-spaces, they need to be enclosed in ( ); but normally that captures and saves the contents and at this point we want to capture the entire list of numbers, not individual numbers in the list. (?: starts a non-capturing block that just groups the contents and doesn’t capture.

my ($winning, $mine) = /($numlistre)\s+\|\s+($numlistre)/
or die "didn't parse line $.:\n$_";


Don’t even bother matching the card number; just grab the two lists of numbers (as text).

my (@winning) = split(/\s+/, $winning);

Split the string of winning numbers on whitespace and save the result in an array.

my $value = 0;
$value = $value ? 2 * $value : 1
foreach grep { my $num = $_; grep { $_ == $num } @winning }
split(/\s+/, $mine);

$sum += $value;


Working backwards: Split the string of my numbers into a list, just as the winning numbers were split previously. Do something (grep) with that list. For each element of the list returned by grep, advance the value of this line — double it if it’s already non-zero, or advance it to 1 if it’s zero.

Now the grep, working from the outside in. Perl’s grep filters a list based on arbitrary criteria, returning the list of matching elements. So the outer grep loops through all of “my” numbers and returns the list of ones matching the condition inside the block.

In the block, grep sets $_ to each element being examined. Since I’m nesting greps, I cache the current value of the outer grep in $num. I then filter the list @winning of winning numbers looking for any that are $num — in other words, does the number I’m looking at from my list appear in the list of winning numbers?

If this number from my list appears in the list of winning numbers, then the inner grep will return a list containing just that number, or the scalar 1, as the result of the condition block. Either evaluates as true, so this number from my list will be included in the result of the outer grep. The outer grep thus returns the list of my numbers that are winners; and the foreach loop cycles through them advancing the value of the current ticket.

Full Program

#!/usr/bin/perl

print "sum: $sum\n";


I could trivially update my flood fill to prime the stencil only with * characters and then it would find only numbers adjacent to them; but I’d still have to write new code to count the quantity of numbers adjacent to * characters; and by the time I’ve done that, I might as well use it in the main loop also.

Because


..123...
...*....
456.....


that star has a whole lot of digits adjacent to it but only two numbers.

New approach: Look for stars; find adjacent digits; immediately find the full string of digits and cache it; flag every position filled by those digits so it’s not picked up again in this particular scan for neighbors; count the cache length.

I’m no longer using subroutines prime and iterate nor a separate @dst array. The code to read the input is unchanged from part 1.

Debugging Output

my $debug = 0;
...
if ($debug) { print join("", @{$_}), "\n" foreach @input; print "\n"; }


I’ve added debugging, which perhaps Perl has developed a more elegant or idiomatic way to do since I learned it sometime around 1992. If I’ve turned on debugging, then dump the input back out by iterating through each line of the array, joining all of the characters of the line, and printing that, plus an extra blank line. This is handy during testing because I haven’t memorized the input and today I’m working on a single laptop screen.

Loop Through Cells

my $sum;
foreach my $row (0 .. $h - 1) {
foreach my $col (0 .. $w - 1) {
next unless $input[$row][$col] eq "*";
print "($row, $col)\n" if $debug;


Loop through the rows of the grid and the columns of each row. If the cell doesn’t contain a *, move on. If debugging, print the coordinates of the current cell (after finding that it has a *).

Loop Through Neighbors

my (@neighboringnums, %seen);
foreach my $n (@neighbor) {
my $rtst = $row + ${$n}[1];
next if $rtst < 0 || $rtst >= $h;
my $ctst = $col + ${$n}[0];
next if $ctst < 0 || $ctst >= $w;


Declare a list to hold neighboring numbers that we find and a hash to flag cells containing digits that are part of numbers we’ve already got and shan’t examine again.

As before, loop through the coordinates of neighbor offsets, ensuring that they don’t fall outside the grid.

next if $seen{$rtst}{$ctst};
next unless isdigit($input[$rtst][$ctst]);


If we’ve flagged this neighbor cell as part of a number that we’ve already seen adjacent to this *, then skip it.

If it’s not a digit, then skip it.

Extract the Number

# Found an adjoining digit that we haven't seen yet.
# Extract the whole number. First, find its left edge.
my $nx = $ctst;
-- $nx while $nx > 0 && isdigit($input[$rtst][$nx - 1]);
print "\t($nx, $col)\n" if $debug;


($ctst, $rtst) are the coordinates of a newly-discovered digit adjacent to a *. Get the whole number that it’s part of.

Set the number’s x coordinate $nx to the x coordinate of the digit we just found. Now decrement that position (move left) as long as we’re not passing the left edge of the array and as long as the cell to our left contains a digit.

Once we get there, if debugging, print these coordinates of the left edge of this number (string of digits), one tab indented.

# Now build the number and mark it seen by this gear.
my $num;
do {
$num .= $input[$rtst][$nx];
++ $seen{$rtst}{$nx};
} while $nx < $w - 1 && isdigit($input[$rtst][++$nx]);
print "\t\t[$num]\n" if $debug;

push @neighboringnums, $num;


We're at the beginning of a string of one or more digits, at least one of which is adjacent to a *. Accumulate those digits into the string $num and mark their positions not to be examined again while searching neighbors of this *.

Append the current digit to $num. Mark this position as already used ... and although I narrate here in (x, y) coordinates, maintain the (row, column) convention used by @input's indices even in the %seen hash. Keep appending cells as long as we're not past the right edge of the grid and the next character to the right is another digit.

If debugging, print the resulting number string, two tabs indented.

Push that number on the list of numbers (not just digits) found neighboring this *.

Two Neighboring Numbers?

$sum += $neighboringnums[0] * $neighboringnums[1] if
@neighboringnums == 2;


If we found two neighboring numbers, add their product to our running sum.

Here, the array-to-scalar context of @neighboringnums is caused by the scalar comparison to the scalar 2 and scalar context needn't be specified explicitly. It's idiomatic in Perl only to specify context explicitly when the array is in an array-or-scalar context (argument to a multi-argument function like print) or when the code is so dense that the meaning would be unclear.

Coulda Done Part 1 This Way

Obviously. Search for neighbors of symbols and extract full numbers immediately. Move %seen outside the outermost cell loop so that each number only gets picked up once.

Full Program

#!/usr/bin/perl

sub isdigit {
return $_[0] =~ /^\d$/;
}


467..114..
...*......
..35..633.
......#...
617*......
.....+.58.
..592.....
......755.
...$.*....
.664.598..


As the sample logic states, in the sample input, only 114 and 58 aren’t adjacent to any symbols.

I thought for a while about a couple of ways to do this and settled on a flood fill. This was an incorrect choice that happened to work on my particular input but is not a proper solution, so I got unreasonably lucky.

Flood filling is an algorithm, commonly used in computer paint programs (or at least it used to be), for filling a region of cells bounded by a closed curve of some marker condition with a new condition — in other words, filling the inside of a shape you just drew.

I use it here like this: Imagine covering that input grid with an opaque piece of paper. Punch holes in it where the symbols are and put it back on top of the grid; all you can see are symbols. Wiggle your stencil around and get a peek at what surrounds the symbols — anywhere you find a digit adjacent to a hole, punch out the stencil above that digit also and put it back over the grid. Then wiggle some more looking for digits adjacent to already-uncovered digits and punch holes over those. Keep repeating until you don’t see any more adjacent digits and don’t punch any more holes; then you’re done.

This will find digits that are adjacent to symbols and then “uncover” the rest of the numbers of which those digits are members.

It will also incorrectly find digits vertically and diagonally adjacent to other digits, even when the newly-found digits aren’t adjacent to a symbol:

.....1..
...234..
567...*.
........


Here, 1 and 567 shouldn’t be selected, but my flood fill will include them. That’s wrong; and that’s how my program works; and I find myself very surprised that the actual input didn’t contain any number placements that would trigger this error.

So … let’s talk about how I wrote this; and then in part 2 you can see that (for other reasons) I had to change my approach to something that would have been more appropriate here.

Subroutines

sub prime;
sub iterate;
sub isdigit; # missing from POSIX on my system ?!


I’m going to use some subroutines in this program. In Perl, you can call a subroutine without having defined it first by using the syntax &iterate; or you can define it first and use the syntax iterate. Today I felt like having a reminder of my list of subroutines and using the latter syntax, so I define them at the top.

The third subroutine definition bears some explanation. I’m going to want a quick way to check whether a character is a digit, and normally one would write:

use POSIX qw(isdigit);

if (isdigit($var)) { ... }


but the MacBook on which I wrote today’s programs says

"isdigit" is not exported by the POSIX module

???! So I made my own:

sub isdigit {
return $_[0] =~ /^\d$/;
}


Global Arrays

my (@input, @dst);

I’m going to store the input in a two-dimensional array and I need a second two-dimensional array for the flood-filled copy. I declare them here as global variables. Global variables aren’t normally a great programming practice but here I’m going to share them between multiple subroutines; and because that’s all these subroutines are doing, there’s no point in passing the arrays as parameters to the subs. Think of these as lexically-scoped variables shared among functions in foolib.c that aren’t defined-extern in foolib.h so they’re not visible from main.c, only here I haven’t bothered to make a separate foolib.c .

my @neighbor = ( [-1, -1], [0, -1], [1, -1],
[1, 0], [1, 1], [0, 1], [-1, 1], [-1, 0] );


I make a list of the (xoffset, yoffset) coordinates for the eight neighbors of a cell. @neighbor is an array of arrays — technically an array of array references, but in Perl we don’t talk about that as much as we have to in C(++). The ( ) presents a list to initialize @neighbor and each [ ] within it creates a list and returns its reference to become a member of @neighbor. Later we can access these as $neighbor[3][0] for the x offset and $neighbor[3][1] for the y offset.

Read the Input

# Slurp the entire input into a two-dimensional array.
chomp, push(@input, [ split(//) ]) while <>;
my $h = scalar @input; my $w = scalar @{$input[0]};
print "$w x $h\n\n";


Perl offers syntax variants to write very compact code that’s easily read by the fluent and which contributes to its reputation for unintelligibility among everyone else.

... while condition;

is equivalent to

while (condition) { ... }

– it executes the statement or block as long as the condition is true. The condition <>, which I use in every AoC program, is a built-in that reads the next line of input, stashes it in the special variable $_ that’s the default for operators that don’t specify a variable on which to operate, and returns true until eof and then returns false. So this will loop through the input, stashing each line in $_.

Each line of input has a newline at the end and split will blithely treat that like any other character, building it into my array. I don’t want that; so chomp discards any line-separator present in a string and doesn’t discard anything if no line separator is present.

Then split the line into separate characters (split(//) splits between characters; and without a parameter for which string to split, it defaults to splitting the current line of input, $_); encapsulate that as a list/array and return the array reference; and push that onto the end of the list of rows of input. The comma operator allows two (or more) operations in sequence and has a very poor order of precedence compared to arithmetic, logical, and list operators but higher than loop commands; so it allows me to chomp and push still using the one-line loop syntax.

Having read the entire input file into an array in one line of code, grab the height (number of rows) and width (number of elements of the first [zeroeth] row), then print those out as a reassurance that the program is doing something sane. scalar causes an arbitrary data type to be interpreted in scalar context and an array in scalar context returns the number of elements in the array. And an instance where we do have to worry about array references: $input[0] is an array ref, not an array; so we must cast it (rather than dereference as in C) to an array @{$arrayref} in order to apply the scalar cast to get its length.

Subroutine Calls

prime;
iterate;


Call the previously-defined subroutines to prime my flood fill and iterate my flood fill, whatever those may entail.

Calculate the Result

my $sum;
foreach my $row (@dst) {
$sum += $_ foreach join("", @{$row}) =~ /(\d+)/g;
}
print "sum is $sum\n";


For every row of the @dst destination array; and within that, for every something or other, add it to $sum, then print that.

From the inside out, $row is an array ref, not an array, so @{$row} cast it as an array. Join the elements of that array into a string with no field separators added. To that string, apply a regular expression that (\d+) looks for and saves strings of digits, /g as many of them as there may be in the string (regex modifier mnemonic: look again). Iterate through all of those saved results and for each one of them, add the intrinsic loop variable $_ to the sum.

Prime the Stencil

# Copy everything except digits from input array to destination array,
# leaving dots in all blank positions of both arrays.
sub prime() {
foreach my $row (0 .. $h - 1) {
foreach my $col (0 .. $w - 1) {
my $in = $input[$row][$col];
$dst[$row][$col] = isdigit($in) ? "." : $in;
$input[$row][$col] = "." unless isdigit($in);
}
}
}


I’m retaining the puzzle author’s selection of using dot to indicate a blank. For my flood fill, I’m going to destructively scan @input and move matching parts of it to @dst; so that starts here by “creating the initial stencil” — priming the initial contents of @dst.

Loop through all the cells of @input For each cell, if it’s a digit, don’t copy/move it to @dst; populate with a dot (blank space) instead. For any other character, move it over, replacing it in @input with a dot (which might be what was there to begin with).

Now @dst is primed with all of the symbols and nothing else.

Iterate Flood Filling

# Move digits from input array to destination array that are adjacent
# to anything in destination array until nothing more is moving.
sub iterate() {
my $changing;
do {
$changing = 0;


Recall that we’re going to keep “wiggling the stencil” looking for adjacent digits until we don’t find any more. I’m tracking that in the variable $changing, which needs to be defined outside the loop so it can be checked in the loop condition, and cleared at the beginning of each iteration of the loop. This outer loop is multiple iterations of “wiggling the stencil.”

foreach my $row (0 .. $h - 1) {
cell: foreach my $col (0 .. $w - 1) {
my $in = $input[$row][$col];
next unless isdigit($in);


Each time we wiggle the stencil, we need to look at whether any digits are adjacent to “holes” in the stencil. We can do this two ways: look at every digit in the grid and see whether it’s adjacent to a hole or look at every hole in the stencil and see whether it has digits adjacent to it. I chose the former.

So loop through the grid and skip on to the next cell if we’re not looking at a digit.

foreach my $n (@neighbor) {
my $rtst = $row + ${$n}[1];
next if $rtst < 0 || $rtst >= $h;
my $ctst = $col + ${$n}[0];
next if $ctst < 0 || $ctst >= $w;


Having found a digit in @input that we haven’t determined to be adjacent to a “hole in our template” and moved over to @dst yet, look at all of the cells surrounding our digit. Loop through the list of (xoffset, yoffset) pairs for all eight neighbor adjacencies; for each, add the offsets to the current coordinates to get the coordinates ($ctst, $rtst) of the @dst stencil cell that we want to test/examine. If the offsets take us out of bounds of the grid, skip this neighbor position and move on to the next.

if ($dst[$rtst][$ctst] ne ".") { # have neighbor
$dst[$row][$col] = $in;
$input[$row][$col] = ".";
++ $changing;
next cell;
}


For a neighbor position that’s within the grid, recall that the only things left behind in @input are digits that we don’t yet know are adjacent to symbols or other digits. So if a neighbor position is non-empty, then we’re interested in it and we want to move it from @input to @dst. Set the cell of @dst to that value; clear that cell of @input; note that we’ve experienced a change on this iteration of wiggling the stencil; and stop examining other neighbors of this digit because we’ve already vetted and moved it.

} # if neighbor
} # neighbor
} # col
} # row
} while $changing;


Keep looping through neighbors of the current maybe-digit cell, and columns of the row, and rows of @input, and iterations of wiggling the stencil, as long as we’re still finding new digits to move over.

Reminder That This Is Wrong; How to Fix

Again, this code picks up digits that it shouldn’t, due to inappropriate use of flood filling, specifically digits vertically and diagonally adjacent to other digits rather than symbols.

This could be remedied within a flood fill algorithm by renaming @neighbor to @symbolneighbor and then making a shorter @digitneighbor that only contains left and right offsets ( [-1, 0], [1, 0]). Then either:

• Retain the approach of scanning cells of @input for remaining digits; scan their @symbolneighbor neighbors for symbols; and scan their @digitneighbor neighbors for digits.
• Change to scanning @dst for populated cells; scan the @symbolneighbor neighbors of symbols and the @digitneighbor neighbors of digits in @dst for digits in @input.

The latter strikes me as cleaner and more intelligible.

Full Program

#!/usr/bin/perl

sub isdigit {
return $_[0] =~ /^\d$/;
}