#!liberate perl (Huh?)
These are my solutions to 2017's Advent of Code puzzles! They're all here! Last year, I did most of the problems in Elixir, a mostly-new language for me. This year, I'm using Perl, a mostly-new language for me! I'm using Perl for two reasons:
But not just any Perl. No, this Perl is literate! My code is embedded in a Markdown document, in the spirit of the literate flavor of Coffeescript (RIP). Now, Topaz may tell you that Markdown is an abomination and that you should use Nimble instead because it sucks less. And he may be right. Or not. I don't know. I'm just, like, a programmer, man.
What you are reading is (technically) a source file. Depending on where and how you are reading it, it may look quite pretty. GitHub is quite good at making source files look pretty. But even if you are looking at the raw plaintext (as I do when writing) it will still be quite legible. In fact, it looks like this:
Ain't that schwifty? If you think this is neat, you may wish to peruse some other bits like it:
vimrcwrit.js.mdIf you are impatient, you can jump to a given day's solution
Otherwise, let's jump in and sling some semicolons.
You're supposed to do this in Perl. I don't know exactly why, but it doesn't hurt, so.
use warnings;
use strict;
use v5.26;
use Switch;
use List::Util qw/min max first/;
use File::Slurp qw/read_file/;
$DEBUG is very sophisticated. Not really, but it is undeniably useful, so.
my $DEBUG = 0;
sub dprint {
print @_ if $DEBUG;
}
Grab a given day's input with input($day). Maybe some day we'll auto-fetch it?
sub input {
my $arg = shift;
my $input = read_file("input.$arg.txt") or return "pants";
dprint "<INPUT>\n$input</INPUT>\n";
return $input;
}
Shield your eyes.
sub compound_solve {
my $i = 0;
while (my $ref = shift) {
print "\nPart $i\n"; ++$i;
print "-------\n";
$ref->();
}
}
Make an array of arrays out of a bunch of text. Lots, if not most, inputs have been 2d grids of stuff, usually numbers. They are usually rectangular but it's best not to assume so.
sub to_jagged_array {
my @lines = split '\n', shift;
my @ary = map {[split /\s/]} @lines;
return @ary;
}
Sum the 8 adjacent squares on a grid. Handles undef as if it were 0
sub sum8 {
my ($x, $y, %grid) = @_;
my $sum = ($grid{$x-1}{$y } or 0) +
($grid{$x-1}{$y+1} or 0) +
($grid{$x-1}{$y-1} or 0) +
($grid{$x }{$y+1} or 0) +
($grid{$x }{$y-1} or 0) +
($grid{$x+1}{$y } or 0) +
($grid{$x+1}{$y+1} or 0) +
($grid{$x+1}{$y-1} or 0);
return $sum;
}
Sum the 4 immediately adjacent squares on a grid (no diagonals).
sub sum4 {
my ($x, $y, %grid) = @_;
my $sum = ($grid{$x-1}{$y } or 0) +
($grid{$x }{$y+1} or 0) +
($grid{$x }{$y-1} or 0) +
($grid{$x+1}{$y } or 0);
return $sum;
}
Sum the 4 diagonally adjacent squares on a grid.
sub sum4x {
my ($x, $y, %grid) = @_;
my $sum = ($grid{$x-1}{$y+1} or 0) +
($grid{$x-1}{$y-1} or 0) +
($grid{$x+1}{$y+1} or 0) +
($grid{$x+1}{$y-1} or 0);
}
Check an array (of strings) for duplicates. Return 1 iff there is a duplicate value.
sub has_dupe {
my (@ary) = @_;
while (my $q = shift @ary) {
foreach my $p (@ary) {
print "$p/$q\n" and return 1 if $p eq $q;
}
}
return 0;
}
Similarly, check an array for strings which are anagrams of one another. This is perhaps not a great general-use helper. It will live here for now. Just in case.
sub has_anagram {
my (@ary) = @_;
while (my $q = shift @ary) {
foreach my $p (@ary) {
print "$p/$q\n" and return 1 if
(join '', sort { $a cmp $b } split(//, $p)) eq
(join '', sort { $a cmp $b } split(//, $q));
}
}
return 0;
}
It's all downhill from here, folks. day1 through dayN will take input (hopefully from
input.N.txt), do something with it, and print stuff. Hopefully the right answer.
Yeah it's butt-ugly. No, I'm not sorry. I'm learning!
sub day1 {
my $sum = 0;
my $input = input(1);
for (my $i = 0; $i < length($input); ++$i) {
$sum += +(substr($input, $i, 1)) if substr($input, $i, 1) eq substr($input, ($i+(2132/2))%2132, 1);
}
print "Sum: $sum\n";
}
Still not sorry.
sub day2 {
my $input = input(2);
my @lines = split('\n', $input);
my $checksum = 0;
foreach my $line (@lines) {
my $hi = 0;
my $lo = 99999;
my @nums = split(/\s/, $line);
$hi = max(@nums);
$lo = min(@nums);
foreach $a (@nums) {
foreach $b (@nums) {
if ($a % $b == 0 && $a != $b) {
$checksum += $a / $b ;
dprint "($a/$b)"
}
}
}
dprint $line . ":: $checksum\n";
}
print "Checksum is $checksum\n";
}
n.b. See also: Ulam Spiral
I quickly noticed the pattern 1, 9, 25 in the example: Bottom-right corners of each layer are the squares of odd numbers. This gives us an anchor that we can calculate manhattan distances relative to. I ended a sentence with a preposition, but that's okay, because Perl is not English.
The idea is simple: find the largest odd-square n^2 less than our input. That number has
a manhattan distance of 1 + (n - 1) / 2. Then we can use the remainder, along with the
number of sides it "wraps" around, to figure out its own manhattan distance.
As evidenced from the mess below, I had a harder time wrapping my head around the exact mechanics of it all. sic erat scriptum. Not pictured is a bunch of mental math and calculator checks.
Fortunately, my input wasn't just larger than an even square, because then I'd be in trouble. Perhaps that was intentional. Either way, I took advantage of it to avoid extra odd/even logic.
# Where side == 6 because sqrt(25)+1
# 25 => 2+2 = 4
# 26 => 2+2+1 = 5
# 27 => 2+2+1 - 1 = 4
# 28 => 2+2+1 - 2 = 3
# 29 => 2+2+1 - 1 = 4
# 30 => 2+2+1 = 5
# 31 => ... = 6
# 32 => ... = 5
# 33 = 4
# 34 = 3
# 35 = 4
# 36 = 5
# 37 = 6
sub day3_part1 {
my $input = input(3);
my $sqrt = int(sqrt($input));
my $corner = $sqrt * $sqrt;
my $side = $sqrt+1;
my $side2 = $side / 2;
my $wrap = $input - $corner;
my $rem = $wrap % $side;
my $spillover = abs($rem - $side2);
my $wat = $side2 + $spillover;
print "Corner: $corner\n";
print "sqrt: $sqrt\n";
print "side: $side\n";
print "side/2: $side2\n";
print "wrap: $wrap\n";
print "rem $rem\n";
print "spillover: $spillover\n";
print "side / 2 + spillover: $wat:\n";
}
This was the first day where my solution for part 2 was completely different than that for part 1. Since the spiral is now defined in a dynamic way, I just implemented it like that, rather than trying to be clever and formulaic.
It turns out that this exact sequence is in fact A Thing! The world is a remarkable place.
In any case, I wasn't wise enough to refer to OEIS, so just hacked out the following.
The key insights are:
layer * 2, so the layers are sized thusly:
| Layer | Side | Grid Formed |
|---|---|---|
| 0 | 1 | Single Cell |
| 1 | 2 | 9-grid |
| 2 | 4 | 25-grid (5x5) |
| 3 | 6 | 49-grid (7x7) |
| 4 | 8 | ...and so on |
sub day3 {
my $input = input(3);
my %grid = ();
my $seed = 1;
$grid{0}{0} = $seed;
my $layer = 1;
while (1) {
my $side = $layer * 2;
my $anchorX = $layer;
my $anchorY = $layer;
my $x = $anchorX;
my $y = $anchorY;
for (my $i = 0; $i < 4; ++$i) {
for (my $j = 0; $j < $side; ++$j) {
if ($i == 0) {
--$y;
}
elsif ($i == 1) {
--$x;
}
elsif ($i == 2) {
++$y;
}
else {
++$x;
}
my $num = sum8($x, $y, %grid);
dprint "[Layer = $layer, Side = $side, aX = $anchorX, aY = $anchorY] ($x,$y): $num\n";
$grid{$x}{$y} = $num;
if ($num > $input) {
print "Num: $num\n";
exit;
}
}
}
++$layer;
}
}
I have a feeling we'll be seeing more square spirals in the coming days, so I intend to clean this business up a bit to make it reusable at the drop of a hat. But not now.
Okay, this is actually not terrible. It's not good, but...not terrible.
sub day4_part1 {
my $input = input(4);
my @lines = to_jagged_array($input);
my $valid = 0;
foreach my $l (@lines) {
next if (has_dupe(@$l));
++$valid;
}
print $valid;
}
Copypasta at its finest. Copy-filet-mignon, if you will.
sub day4_part2 {
my $input = input(4);
my @lines = to_jagged_array($input);
my $valid = 0;
foreach my $l (@lines) {
next if (has_anagram(@$l));
++$valid;
}
print $valid;
}
Another mercifully short solve. Part 2 was a trivial if-else addition I won't even bother recording.
Things that slowed me down on day 5:
last instead of break
sub day5 {
my $input = input(5);
my @nums = split("\n", $input);
my $p = 0;
my $i = 0;
while (1) {
$p += $nums[$p]++;
$i++;
if ($p >= scalar @nums or $p < 0) {
last;
}
}
print $i;
}
β (Except not)
I actually slept through the unlock (I was very tired) so I solved this one at a leisurely
pace (the better to learn effectively, my dear). I've no idea how I would have placed, but
I am guessing "not well" because List::Util#first
is one of Perl's many "foolish human, you thought I would do that, but instead I do this" functions.
I assumed, as any reasonable human would, that first { $banks[$_] == max(@banks) } @banks
would give the right result. It does not. It does not even give the wrong result. Instead,
it errors out and results in my $i uninitialized. The right way to do it is
first { $banks[$_] == max(@banks) } 0..$#banks.
It would have been faster to find the "first max" by hand, but I didn't know that when I decided to use the built-in thing. Hindsight's 20-20.
sub day6 {
Set up initial state.
my $input = input(6);
my @banks = split /\s+/, $input;
my %seen = ();
my $cycles = 0;
Condense @banks into a string in order to hash seen states.
until (exists($seen{join ',', @banks})) {
$seen{join ',', @banks} = 1;
say "Banks: @banks";
my $i = first { $banks[$_] == max(@banks) } 0..$#banks;
my $val = $banks[$i];
$banks[$i] = 0;
while ($val--) {
++$i;
$i %= scalar @banks;
$banks[$i]++;
}
++$cycles;
Part 2 was fun because (a) it asked what any inquisitive mind would naturally ask halfway through solving part 1, namely, "how does this cycle?"; and (b) I used a clever™ hack to get it slightly faster.
Instead of factoring out the contents of this loop into a subroutine, as any good programmer would, or copy-pasting it for a second go-round, as any bad programmer would...
say " => @banks";
I added this line to get the ending (repeat) state, ran it again on my initial input, pasted that into my input, then ran it once more. I suppose this makes me a badong programmer. No, I'm definitely not sorry.
}
say "Cycles taken: $cycles";
}
Part 1 was not so bad once I actually parsed the input correctly. This is gnarly, but the basic idea is simply to index each program's name into its parent. Then we can walk upward (downward?) from any leaf node (I used the first, why not) until we arrive at the root.
sub day7 {
my $input = input(7);
my @lines = split("\n", $input);
my @subs = ();
my @names = ();
my %tree = ();
foreach my $line (@lines) {
my @parts = split '->', $line;
my $left = $parts[0];
my ($name, $weight) = split ' ', $left;
if ($parts[1]) {
my $right = $parts[1];
my @subprogs = split ', ', $right;
foreach my $sub (@subprogs) {
$tree{$sub} = $name;
}
}
unshift @names, $name;
}
my $something = $names[0];
$something = $tree{$something} while exists $tree{$something};
print "Base: $something\n";
}
Part 2 is gnarly.
The weights matter.
I think recursion is not mandatory, but it's a work in progress, so maybe it is.
Best I can tell at this point, we need to build bottom-up, but build weights top-down
then traverse bottom-up to find the unbalanced node. Β―\_(γ)_/Β―
sub day7_part2 {
my $input = input(7);
my @lines = split("\n", $input);
my %tree = ();
my %weights = ();
my @leaves = ();
foreach my $line (@lines) {
my @parts = split '->', $line;
my $left = $parts[0];
$left =~ /(\w+) (\(\d+\))/;
my ($name, $weight) = ($1, $2);
dprint "Name: $name, weight: $weight\n";
unshift @leaves, $name;
$weights{$name} = $weight;
if ($parts[1]) {
my $right = $parts[1];
my @subprogs = split ', ', $right;
foreach my $sub (@subprogs) {
$tree{$sub} = $name;
}
}
foreach my $name (@leaves) {
#say "Leaf: $name" unless grep /^$name$/, values(%tree);
my $parent = $tree{$name};
}
}
}
Not too terrible. This solution covers both parts, and is more or less as-written.
In hindsight, a regex destructuring was not really necessary, and actually slowed me down as I had to balance parens, and accidentally a term.
Instead, I should have gone something like
my ($reg, $op, $num, $ignored, $test, $condition, $compare) = split ' ', $line.
I'm very glad eval was at my disposal. I know that it's evil, but think of the poor
Java programmers who had to construct some janky-ass switch statement, after reading
the entire input to make sure they didn't miss an operator. Sometimes when there's
a job needs doing, it's okay to make a deal with the devil.
sub day8 {
my $input = input(8);
our %regs = ();
my $fullmax = 0;
foreach my $line (split "\n", $input) {
$line =~ /(\w+) (inc|dec) (\S+) if (\w+) (.*)/;
my ($reg, $op, $num, $test, $condition) = ($1, $2, $3, $4, $5);
if (eval('($regs{$test} // 0) ' . $condition)) {
$regs{$reg} += $num if ($op eq 'inc');
$regs{$reg} -= $num if ($op eq 'dec');
}
$fullmax = max(values %regs, $fullmax);
}
printf "Historical Max: %s\n", $fullmax;
printf "Last Max: %s\n", max(values %regs);
}
I could do something clever when we run ./aoc.md.pl. But I won't.
unless (scalar @ARGV) {
print "Usage: $0 day <day>\n" and exit;
}
Grab option flags. If I were a better programmer, I would make it so these did not have
to come first; sometimes you just want to tack on -d to the thing you just ran, and
have it just do the thing. But I am not a better programmer. So I won't.
while ($ARGV[0] =~ /^-(\w)/) {
my $flag = shift;
$DEBUG = 'true' if $1 eq 'd';
dprint "Got flag $flag\n";
}
Right before solving day 3 I learned that subrefs are a thing, and they look funny but they totally work! It's an array of functions! Or references to them, anyhow.
my @solutions = (
sub { print "I'm in ur index sploiting ur off-by-ones\n" },
\&day1,
\&day2,
sub { compound_solve(\&day3_part1, \&day3) },
sub { compound_solve(\&day4_part1, \&day4_part2) },
\&day5,
\&day6,
sub { compound_solve(\&day7, \&day7_part2) },
\&day8,
\&day9,
);
day is the only "command" supported here. It is mostly for ceremony and clarity.
There is, though, the convenient side-effect of the else block below...
if (shift @ARGV eq 'day') {
my $daynum = shift @ARGV;
if (exists($solutions[$daynum])) {
$solutions[$daynum]();
}
else {
print "No solution for day $daynum\n"
}
}
...which allows me to type e.g. ./aoc.pl.md pants to run sloppy one-off sanity checks
and such.
else {
# scratchpad
my ($expr) = (@ARGV);
say $expr;
$expr =~ /(\w+)(@(\w+))?/;
my ($name, $host, $wtf) = ($1, $2, $3);
say "$name, $wtf";
}
Also, I just want to say, this is beautiful. Wow.