#!liberate perl (Huh?)

𝅘𝅥𝅯 ‘Tis the season to [REDACTED]! La la, la, la

Git Gud Ante: Upped Speed: Ludicrous Askalski: NOOOOO

These are my solutions to 2017’s Advent of Code puzzles! They’re all here! Well, most of them, anyway. 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:

Literate Perl in Vim

Ain’t that schwifty? If you think this is neat, you may wish to peruse some other bits like it:

Solution List for the Lazy

TODO Finish day 20-25

# TODO: Prettify TODOs

Day 01Day 02Day 03Day 04Day 05

Day 06Day 07Day 08Day 09Day 10

Day 11Day 12Day 13Day 14Day 15

Day 16Day 17Day 18Day 19Day 20

Day 21Day 22Day 23Day 24Day 25

(I went on a Vim side-quest to insert those badges. Learned how to insert vimscript expressions from insert mode (<C-R>=) and recorded this fun macro:)

o[![Day ^R=day^M](https://img.shields.io/badge/day-^R=day^M-green.svg)](#day-^R=day^M):let day+=1^M

Hooray, learning! Anyway, let’s jump in and sling some semicolons.

Cargo all the cults

You’re supposed to do this in Perl. I don’t know exactly why, but it doesn’t hurt, so.

use warnings;
use strict;

Be Modern

Evidently I used Perl 5.26 somewhere. In any case, many Ubuntu doesn’t ship with it, so this might not work without the Perl from 2018. Oops.

use v5.26;

For that Unicode goodness in day 14. Per StackOverflow

use utf8;
use open ':std', ':encoding(UTF-8)';

Imports

use Switch;
use List::Util qw/reduce min max uniq first/;
use List::MoreUtils qw/pairwise zip/;
use File::Slurp qw/read_file/;
use Getopt::Long qw/GetOptions/;
use Term::ANSIColor 'colored';

Helpers

Usage

sub usage {
  print "Usage: $0 day <day>\n" and exit;
}

Debug

$DEBUG is very sophisticated. Not really, but it is undeniably useful, so.

my $DEBUG = 0;

sub dprint {
  return unless $DEBUG;
  print @_;
}

sub dsay {
  say @_ if $DEBUG;
}

Load Input

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;
}

Combine Parts 1 and 2

Shield your eyes.

sub compound_solve {
  my @a = @_;
  return sub {
    my $i = 1;
    while (my $ref = shift @a) {
      print "\nPart $i\n"; ++$i;
      print "-------\n";
      $ref->();
    }
  }
}

To Jagged Array

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;
}

Gridwise Operations

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 for Duplicates

Check an array for duplicates. Return 1 iff there is a duplicate value.

sub has_dupe {
  return (scalar (@_) != scalar (uniq @_));
}

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) {
      dprint "$p/$q\n" and return 1 if
       (join '', sort { $a cmp $b } split(//, $p)) eq
                (join '', sort { $a cmp $b } split(//, $q));
    }
  }
  return 0;
}

SOLUTIONS

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.

Day 1

Inverse Captcha View Puzzle Solution%20Megathread

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";
}

Day 2

Corruption Checksum View Puzzle Solution%20Megathread

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";
}

Day 3

Spiral Memory Solution%20Megathread

#sorrynotsorry

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";
}

Part 2

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:

The Layers, Duke

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.

Day 4

High-Entropy Passphrases Solution%20Megathread

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;
  }
  say $valid;
}

Part 2

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;
  }
  say $valid;
}

Day 5

A Maze of Twisty Trampolines, All Alike Solution%20Megathread

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:

    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)

Day 6

Memory Reallocation Solution%20Megathread

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";
}

Day 7

Recursive Circus Solution%20Megathread

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 I used it, because I’m not upping the ante that much So we 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 = ();

  our %weights = ();
  our %children = ();
  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";

    $weights{$name} = $weight;

    if ($parts[1]) {
      my $right = $parts[1];
      my @subprogs = split ', ', trim($right);
      printf "Subs '%s'\n", join '/', @subprogs;
      foreach my $sub (@subprogs) {
        $tree{$sub} = $name;
      }
      @{ $children{$name} } = @subprogs; # https://stackoverflow.com/a/12535442
    }
    else {
      unshift @leaves, $name;
    }

  }

  sub recurse {
    my $root = shift;
    my $depth = shift;
    return $weights{$root} unless exists $children{$root};

    my @kids = @{ $children{$root} };
    dprint "Kids: " . join(',', @kids) . "\n";
    my @kidweights = map { recurse($_, $depth) } @kids;
    if (scalar(uniq @kidweights) > 1) {
      my $indent = ' ' * $depth;
      say "$indent Found unbalanced node $root with kids @kids, weights @kidweights";
    }
    return sum(@kidweights) + $weights{$root};
  };

  print recurse('dtacyn', 0);
}

Day 8

I Heard You Like Registers Solution%20Megathread

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);

}

Day 9

Stream Processing Solution%20Megathread

(Or, how I learned to stop worrying and locate my missing semicolon?)

I’ll be honest, I was expecting to spend hours debugging a real humdinger like days 3 and 7. This puzzle was really not bad at all, despite the mess below, which, again, I will not be cleaning up because that’s quot erat scriptum, and also I have no shame.

What was quite bad, indeed, and cost me 30 sproinking minutes of debugging what was probably a correct solution from the get-go (and debugging the bugs I introduced with my diagnostics), was the fact that my input got truncated to 4096 chars out of the 15-thousand-odd in my actual input. This is either a limitation of the MinTTY console, or cat, I’m not sure which. Either way I’m seriously considering wiring up some fancy input-fetching business for future problems, but I really don’t wanna.

sub day9 {
  our $input = input(9);

In any case, my misadventures lead to defining impl just so that I could more easily verify my code against the examples, as seen below. Part 2 (the $trashman local) is included.

  sub impl {
    my $arg = shift;
    my @chars = split //, $arg;
    my $depth = 0;
    my $score = 0;
    my $trashman = 0;

As soon as I started reading, I expected some sort of state machine funny business. In fact, all that’s needed here is a true/false garbage flag. sic.

    my $state = 'CLEAN';

Originally started simply shift @chars. The indexed loop was added just for diagnostics.

    for (my $i = 0; $i < scalar @chars; ++$i) {
      my $c = $chars[$i];
      if ($c eq '!') {
        dprint "Skipping $i and next\n";
        ++$i;
        next;
      }
      if ($c eq '<') {
        ++$trashman unless $state eq 'CLEAN';
        $state = 'GARB';
        next;
      }
      if ($c eq '>') {
        $state = 'CLEAN';
      }
      if ($state eq 'GARB') {
        ++$trashman;
        next;
      } # Gotcha

      dprint "[$i][$c]: ";
      if ($c eq '{') {
        $depth++;
        dprint "Depth increased to $depth\n";
      }
      if ($c eq '}') {
        $score += $depth;
        dprint "Score upped by $depth to $score\n";
        $depth--;
      }
      dprint "\n";

    }
    say "Score: $score";
    say "Garbage: $trashman";
  }

   #impl '<>' ; #, 0 characters.
   #impl '<random characters>' ; #  17 characters.
   #impl '<<<<>' ; # , 3 characters.
   #impl '<{!>}>' ; # , 2 characters.
   #impl '<!!>' ; # , 0 characters.
   #impl '<!!!>>' ; # , 0 characters.
   #impl '<{o"i!a,<{i<a>' ; # , 10 characters.

   impl $input;

}

Day 10

Knot Hash Solution%20Megathread

Another brutal one. I don’t really want to talk about it.

sub day10_part1 {
  my $skipsize = 0;
  my $pos = 0;
  my $input = input(10);
  chomp $input;
  my @lengths = split ',', $input;
  my @list = (0..255);
  foreach my $l (@lengths) {
    dsay "Position $pos, Skipsize $skipsize, Length $l:";
    for (my $i = 0; $i < $l / 2; ++$i) {
      my $p = ($pos + $i) % scalar @list;
      my $q = ($pos + ($l - 1 - $i)) % scalar @list;
      dsay "  Swapping items $p and $q";
      my $temp = $list[$q];
      $list[$q] = $list[$p];
      $list[$p] = $temp;
    }

    $pos += $l + $skipsize++;
    $pos %= scalar @list;
    dsay join ',', @list;
  }
  my $a = $list[0] * $list[1];
  say "Answer: $a";

}

I’ll just be over here, crying softly to myself, drowning my sorrows in sencha.

sub day10 {
  my $input = input(10);
  chomp $input;
  my @lengths = map { ord($_) } split('', $input);


  my @list = (0..255);
  my $skipsize = 0;
  my $pos = 0;
  push @lengths, (17, 31, 73, 47, 23);
  dsay "Lengths: @lengths";
  foreach my $round (1..64) {
    foreach my $l (@lengths) {
      dsay "Length $l, position $pos, Skipsize $skipsize";
      for (my $i = 0; $i < $l / 2; ++$i) {
        my $p = ($pos + $i) % scalar @list;
        my $q = ($pos + ($l - 1 - $i)) % scalar @list;
        my $temp = $list[$q];
        $list[$q] = $list[$p];
        $list[$p] = $temp;
      }

      $pos += $l + $skipsize++;
      $pos %= scalar @list;
    }
  dsay "List is @list";
  }


  my @hashes = ();
  foreach my $i (map { $_ * 16} 0..15) {
    my @sublist = @list[$i .. $i+15];
    dprint "Block $i is [@sublist]";
    my $xor = reduce { $a ^ $b } @sublist;
    dsay ": $xor";
    push @hashes, $xor;
  }
  say join ',', @hashes;
  say join '', map { sprintf "%02x", $_ } @hashes;

}

Day 11

Hex Ed Solution%20Megathread

Coming soon to a gist near you!

sub day11 { 
  my @ne = ( 0, 1, 0);
  my @nw = ( 1, 0, 0);
  my @s  = ( 0, 0, 1);
  my @sw = ( 0,-1, 0);
  my @se = (-1, 0, 0);
  my @n  = ( 0, 0,-1);
  my %directions = (
    ne => \@ne,
    nw => \@nw,
    s  => \@s ,
    sw => \@sw,
    se => \@se,
    n  => \@n ,
  );

  my @position = (0,0,0);

  my $input = input 11;

  my @moves = split ',', $input;

  # Each move, add $directions{$move} to position
  foreach my $move (@moves) {
    say "move: ", ($move);
    my @m = $directions{$move};
    say "type: ", (@m);

    next;

    $position[0] += $m[0];
    $position[1] += $m[1];
    $position[2] += $m[2];

    while ($position[0] < 0 && $position[1] < 0 && $position[2] < 0) {
      $position[0]++;
      $position[1]++;
      $position[2]++;
    }

    while ($position[0] > 0 && $position[1] > 0 && $position[2] > 0) {
      $position[0]--;
      $position[1]--;
      $position[2]--;
    }
  }

  
  # Reduce 111 => 0 or -1-1-1 => 0
}

Day 12

Digital Plumber Solution%20Megathread

sub day12 {
  our %p = ();
  for my $line (split "\n", input(12)) {
    $line =~ m/(\d+) <-> (.*)/;
    my $r = $1;
    my $c = $2;
    $p{$r} = $c;
    dsay "Setting p $r to $c";
  }

  our %g = ();
  sub recurse12 {
    my $root = shift;
    return if exists $g{$root};
    $g{$root} = 1;
    dsay "Splitting ',' in $root => $p{$root}";
    my @kids = split ', ', $p{$root};
    foreach my $k (@kids) {
      dsay "Recursing for $k";
      recurse12($k);
    }
  }


  my @groups = ();
  my %s = ();
  foreach (0 .. 1999) {
    %g = ();
    recurse12($_);
    my $size = scalar (keys %g);
    my $group = join ' ', sort(keys %g);
    unless (exists $s{$group}) {
      say "$_: $group";
    }
    $s{$group} = 1;
  }

}

Day 13

Packet Scanners Solution%20Megathread

sub day13_part1 {
  my $input = input(13);
  my @layers =();
  foreach my $l ( split("\n", $input)) {
    my ($i, $v) = $l =~ m/(\d+): (\d+)/;
    dsay "$i to $v";
    $layers[$i] = $v;
  }

  my $penalty = 0;
  foreach my $tick (0 .. 99) {
    my $space = $tick;
    my $range = $layers[$space];
    if ($range && ($tick % (2 * ($range - 1)) == 0)) {
      $penalty += $tick * $range;
      dsay "Penalty $penalty at $tick ($range)";
    }
  }
  say "Severity: $penalty";
}

sub day13 {
  my $input = input(13);
  my @layers =();
  foreach my $l ( split("\n", $input)) {
    my ($i, $v) = $l =~ m/(\d+): (\d+)/;
    my  $c = 2 * ($v - 1);
    $layers[$i] = $v;
  }

  foreach my $delay(0 .. 9999999999) {
    my $penalty = 0;
    my @penalties = ();
    foreach my $tick (0 .. 100) {
      my $tpd = $tick + $delay;
      my $range = $layers[$tick];
      next unless $range;
       #say "Layer $tick> $tpd % (2 * ($range - 1)) = ", $tpd % (2 * ($range - 1));
      if ($tpd % (2 * ($range - 1)) == 0) {
        $penalty += $range * $tick;
        push @penalties, "P $penalty\@l.$tick";
        next;
      }
    }
    my $total = join ', ', @penalties;
    say "Delay $delay Severity: $penalty\t[$total]";
    last unless scalar @penalties;
  }
}

Day 14

Disk Defragmentation Solution%20Megathread

My input: hxtvlmkl

TODO: talk about terminal color codes and why you should always check for off-by-ones

my $day14gridsize = 127;
sub day14_part1 {
  my $input = input(14);
  chomp $input;
  say "Input: $input";

  my @grid = ([]);

  my $count = 0;
  for my $row (0 .. $day14gridsize) {
    my @lengths = map { ord($_) } split('', "$input-$row");
    my @list = (0..255);
    my $skipsize = 0;
    my $pos = 0;
    push @lengths, (17, 31, 73, 47, 23);
    dsay "Lengths: @lengths";
    foreach my $round (1..64) {
      foreach my $l (@lengths) {
        dsay "Length $l, position $pos, Skipsize $skipsize";
        for (my $i = 0; $i < $l / 2; ++$i) {
          my $p = ($pos + $i) % scalar @list;
          my $q = ($pos + ($l - 1 - $i)) % scalar @list;
          my $temp = $list[$q];
          $list[$q] = $list[$p];
          $list[$p] = $temp;
        }

        $pos += $l + $skipsize++;
        $pos %= scalar @list;
      }
    dsay "List is @list";
    }

    my @hashes = ();
    foreach my $i (map { $_ * 16} 0..15) {
      my @sublist = @list[$i .. $i+15];
      dprint "Block $i is [@sublist]";
      my $xor = reduce { $a ^ $b } @sublist;
      dsay ": $xor";
      push @hashes, $xor;
    }
    my $thisrow = join '', map { sprintf "%08b", $_ } @hashes;
    my @arr = split('', $thisrow);
    # Arrays of arrays are hard.
    foreach my $grr (0 .. $day14gridsize) {
      $grid[$row][$grr] = $arr[$grr];
    }
    $thisrow =~ s/0//g;
    chomp $thisrow;
    my $l = length($thisrow);
    $count += $l;
  }
  say $count;
  return @grid;
}

sub day14 {
  my @grid = day14_part1();
  sub floodfill {
    my $grid = shift;
    my $x = shift;
    my $y = shift;
    my $c = shift;
    return if $x < 0 || $x > $day14gridsize;
    return if $y < 0 || $y > $day14gridsize;
    return unless $grid->[$x][$y] eq '1';
    $grid->[$x][$y] = $c;
    floodfill($grid, $x+1, $y, $c);
    floodfill($grid, $x-1, $y, $c);
    floodfill($grid, $x, $y+1, $c);
    floodfill($grid, $x, $y-1, $c);
  }

  my $ch = 2;
  my $regions = 0;
  foreach my $i (0 .. $day14gridsize) {
    foreach my $j (0 .. $day14gridsize) {
      if ($grid[$i][$j] eq '1') {
        dsay "Floodfilling $i,$j with $ch";
        floodfill([@grid], $i, $j, $ch++);
        ++$regions;
      }
    }
    print "\n";
  }

  map { print colored('.', "on_ansi$_") } 0..80;
  say "\n";


  foreach my $i (0 .. $day14gridsize) {
    foreach my $j (0 .. $day14gridsize) {
      use integer;
      my $val = $grid[$i][$j];
      my $back = $val % 255;
      my $fore = $val / 255;
      print ($val ? colored($val % 10, "ansi$fore on_ansi$back") : '.' );
    }
    print "\n";
  }

  say "$regions regions";
}

Day 15

Dueling Generators Solution%20Megathread

I’m still here! I’m just not feeling very talkative.

In actual point of fact, I had to revisit this one in 2019, two years later.

It turns out that two bugs prevented me from nailing it the first time around:

Parents, talk to your kids about the danger of transposing digits.

sub day15_part1 {
  my ($inputA, $inputB) = (783, 325);
  # my ($inputA, $inputB) = (65, 8921); # Example inputs
  my $factorA = 16807;
  my $factorB = 48271;
  my $count = 0;
  say '';

  my $tries = 0;
  for my $i (1 .. 40_000_000) {
    printf "%10d\t%10d", $inputA, $inputB if $DEBUG or ($i % 100 == 0);
    $inputA *= $factorA;
    $inputA %= 2147483647;
    $inputB *= $factorB;
    $inputB %= 2147483647;
    my $lowSixteenA = $inputA % 65536;
    my $lowSixteenB = $inputB % 65536;
    print "[$inputA \t $inputB]";
    if ($lowSixteenB == $lowSixteenA) {
      ++$count;
      printf "\t%16b\t%16b :: $count ($tries gap)\n", $inputA, $inputB;
      $tries = 0;
    }
    else {
      printf "\t(%16b\t%16b)", $lowSixteenA, $lowSixteenB;
    }
    ++$tries;
    print "\r";
    dprint "\n";
  }
  say "\nCount: $count";
}

sub day15 {
  my ($inputA, $inputB) = (783, 325);
  my $factorA = 16807;
  my $factorB = 48271;
  my $count = 0;
  say '';

  my $tries = 0;
  for my $i (1 .. 5_000_000) {
    do {
      $inputA *= $factorA;
      $inputA %= 2147483647;
    } until ($inputA % 4 == 0);
    do {
      $inputB *= $factorB;
      $inputB %= 2147483647;
    } until ($inputB % 8 == 0);

    printf "%10d\t%10d on iteration $i", $inputA, $inputB if $DEBUG or ($i % 100 == 0);

    my $lowSixteenA = $inputA % 65536;
    my $lowSixteenB = $inputB % 65536;
    if ($lowSixteenB == $lowSixteenA) {
      ++$count;
      printf "\t%16b\t%16b :: $count ($tries gap)\n", $inputA, $inputB;
      $tries = 0;
    }
    else {
      printf "\t(%16b\t%16b)", $lowSixteenA, $lowSixteenB;
    }
    ++$tries;
    print "\r";
    dprint "\n";
  }
  say "\nCount: $count";
}

Day 16

Permutation Promenade Solution%20Megathread

Regexes are hard.

Front Matter

sub day16 {
  my @progs = ('a' .. 'p');
  my @in = split ',', input(16);
  my %seen = ();
  my $top = (10 ** 9);
  my @possible = (1 .. 38);
  my $incr = 1;
  for (my $i = 0; $i < $top; $i += $incr) {
    say "$i: ", join '', @progs;
    foreach my $l (@in) {
      $l =~ /((?<cmd>s)(?<num>\d+)|(?<cmd>x)(?<p1>\d+)\/(?<p2>\d+)|(?<cmd>p)(?<p1>[a-p])\/(?<p2>[a-p]))/;
      dprint "$l: ";
      my $cmd = $+{cmd};
      dprint "$cmd: ";

Doing Things

Spinning:

      if ($cmd eq 's') {
        my $num = scalar @progs - $+{num};
        my @a = ();
        push @a, @progs[$num..$#progs];
        push @a, @progs[0 .. ($num-1)];
        @progs = @a;

        dsay join ',', @progs;
        next;
      }


      my $p1 = $+{p1};
      my $p2 = $+{p2};

Exchanging:

      if ($cmd eq 'x') {
        ($progs[$p1], $progs[$p2]) = ($progs[$p2], $progs[$p1]);
        dsay join ',', @progs;
        next;
      }

Partnering:

      my $wat = join ',', @progs;
      $wat =~ s/$p1/T/;
      $wat =~ s/$p2/$p1/;
      $wat =~ s/T/$p2/;
      @progs = split ',', $wat;
      dsay join ',', @progs;
    }

Now we check for a cycle.

    my $wat = join ',', @progs;
    if ($seen{$wat} && $i == 37) {
      my $first = $seen{$wat};
      say "Cycle at $i (first $first) [$wat]";
      my $cycle = ($i - $first);
      say "Cycle length $cycle";
      my $mod = $top % $cycle;
      say "Modulo is $mod";
      say "First is $first";
      my $sol = join('', split(',', $possible[$mod]));
      say "Solution is $sol";
      die "FAIL" unless $sol eq 'bpjahknliomefdgc';
    }
    $seen{$wat} = $i;
    $possible[$i] = $wat;
  }
}

Day 17

Spinlock Solution%20Megathread

I’m starting to feel relatively comfortable with basic Perl by now, so I’m not being hampered by constantly having to look up garden-variety syntax. Of course I’m just scratching the surface of Perl’s myriad features, but for today’s puzzle, that was enough.

Part 1 is relatively straightforward. I took it slow and steady to avoid off-by-one errors and make sure I didn’t misread a requirement. For being sleep-deprived and not working in my “native” programming language (I’m not sure that I even have one, in fact), I placed adequately.

sub day17_part1 {
  my $input = 371;
  my @a = (0);
  my $p = 0;

  foreach my $i (1 .. 2017) {

Advance the position by our input, wrapping as necessary. The size of the buffer is necessarily the same as the current iteration.

    $p = ($p + $input) % $i;
    dprint "$p) ";

Then insert $i as per spec.

    splice @a, $p+1, 0, $i;
    ++$p;
    dsay join ',', @a;
  }

The position ends on 2017, since it was just inserted. The number after that is our solution.

  say "2017 is $a[$p]";
  say "Next is $a[++$p]";
}

For part 2, we can dispose of the list since the actual numbers have no bearing on the solution. As long as we know where zero lies (we do: it’s at index 0 and can never move), we can just check for an “insertion” at that index and take the last such insertion as our solution.

sub day17_part2 {
  my $input = 371;
  my $p = 0;
  my @insertions = ();
  foreach my $i (1 .. 50000000) {
    $p = ($p + $input) % $i;
    push @insertions, $i if ($p == 0);
    ++$p;
    print "\r$i" if $i % 10000 == 0;
  }

I decided to record all insertions after zero, just out of curiosity. Our solution is the final value.

1,2,3,4,15,27,145,2045,110485,1825722,4486326,4785723,5091377,16958671,39170601

There’s an interesting, exponential-ish pattern going on here. Neat!

  say join ',', @insertions;
}

What does yours look like?

Day 18

Duet View Puzzle Solution%20Megathread

This is where I ended in 2017 due to trying to troll Topaz with my part 1 solution and subsequently leaving town to spend Christmas with family. It took another year or so, but I eventually got it!

sub day18 {

My input is:

set i 31
set a 1
mul p 17
jgz p p
mul a 2
add i -1
jgz i -2
add a -1
set i 127
set p 316
mul p 8505
mod p a
mul p 129749
add p 12345
mod p a
set b p
mod b 10000
snd b
add i -1
jgz i -9
jgz a 3
rcv b
jgz b -1
set f 0
set i 126
rcv a
rcv b
set p a
mul p -1
add p b
jgz p 4
snd a
set a b
jgz 1 3
snd b
set f 1
add i -1
jgz i -11
snd a
jgz f -16
jgz a -19

Part 1

Using coding and algorithms Vim, it becomes (diagnostics mine):

  our ($i, $f, $a, $p, $b, $solution, $ptr) = (0,0,0,0,0,0,0);
  dprint '             ';
  dsay join "\t", ('i', 'f', 'a', 'p', 'b', 'sol', 'ptr');
  sub diagnose {
    dsay join "\t", ($i, $f, $a, $p, $b, $solution, $ptr);
  }

  LINE0  : $ptr++; $i = 31;
  LINE1  : $ptr++; $a = 1;
  LINE2  : $ptr++; $p *= 17;
  LINE3  : goto "LINE@{[$ptr += $p]}" if (0 <  $p); $ptr++;
  LINE4  : $ptr++; $a *= 2;
  LINE5  : $ptr++; $i += -1;
  LINE6  : goto "LINE@{[$ptr += -2]}" if (0 <  $i); $ptr++;
  LINE7  : $ptr++; $a += -1;
  LINE8  : $ptr++; $i = 127;
  LINE9  : $ptr++; $p = 316;
  LINE10 : $ptr++; $p *= 8505;
  LINE11 : $ptr++; $p %= $a;
  LINE12 : $ptr++; $p *= 129749;
  LINE13 : $ptr++; $p += 12345;
  LINE14 : $ptr++; $p %= $a;
  LINE15 : $ptr++; $b = $p;
  LINE16 : $ptr++; $b %= 10000;
  LINE17 : $ptr++; $solution = $b;
  LINE18 : $ptr++; $i += -1;
  LINE19 : goto "LINE@{[$ptr += -9]}" if (0 <  $i); $ptr++;
  LINE20 : goto "LINE@{[$ptr += 3]}" if (0 <  $a); $ptr++;
  LINE21 : $ptr++; say "solution: $solution" and return if (0 != $b);
  LINE22 : goto "LINE@{[$ptr += -1]}" if (0 <  $b); $ptr++;
  LINE23 : $ptr++; $f = 0;
  LINE24 : $ptr++; $i = 126;
  LINE25 : $ptr++; say "solution: $solution" and return if (0 != $a);
  LINE26 : $ptr++; say "solution: $solution" and return if (0 != $b);
  LINE27 : $ptr++; $p = $a;
  LINE28 : $ptr++; $p *= -1;
  LINE29 : $ptr++; $p += $b;
  LINE30 : goto "LINE@{[$ptr += 4]}" if (0 <  $p); $ptr++;
  LINE31 : $ptr++; $solution = $a;
  LINE32 : $ptr++; $a = $b;
  LINE33 : goto "LINE@{[$ptr += 3]}" if (0 <  1); $ptr++;
  LINE34 : $ptr++; $solution = $b;
  LINE35 : $ptr++; $f = 1;
  LINE36 : $ptr++; $i += -1;
  LINE37 : goto "LINE@{[$ptr += -11]}" if (0 <  $i); $ptr++;
  LINE38 : $ptr++; $solution = $a;
  LINE39 : goto "LINE@{[$ptr += -16]}" if (0 <  $f); $ptr++;
  LINE40 : goto "LINE@{[$ptr += -19]}" if (0 <  $a); $ptr++;

That’s it!

This is not okay.

}

Part 2

sub day18_part2 {

We need separate memory banks for each program (labelled program 0 and program 1).

  my %p0h = (
    i   => 0,
    f   => 0,
    a   => 0,
    p   => 0,
    b   => 0,
    c   => 0,
    d   => 0,
    ptr => 0,
    sent=> 0,
  );

  my %p1h = (
    i   => 0,
    f   => 0,
    a   => 0,
    p   => 1,
    b   => 0,
    c   => 0, # TODO Remove c and d, they are just for sample input
    d   => 0,
    ptr => 0,
    sent=> 0,
  );

  our @memories = (
    \%p0h,
    \%p1h,
  );

We also need a message queue for each.

  our @q1 = ();
  our @q2 = ();

Load instructions from input. Sadly, Vim will not suffice here.

  our @instructions = split "\n", input(18);
  # our @instructions = split ',', 'snd 1,snd 2,snd p,rcv a,rcv b,rcv c,rcv d';

  my @sent_values = ();

First, a sub to execute one instruction. It takes the PID of the program executing the instruction.

  sub execute_cycle {
    my $pid = shift;
    my $memory_bank = $memories[$pid];

    my $iptr = $memory_bank->{'ptr'};

    if ($iptr < 0 || $iptr > scalar @instructions) {
      dsay 'Out of bounds';
      return 'oob';
    }

    my $instruction = $instructions[$iptr];
    say "[$pid] $instruction";

    my ($op0, $arg1, $arg2) = split ' ', $instruction;

Check if each argument is a register, rather than a constant. If so, “dereference” it.

(Nota bene: this is how you accomplish $arg2 in 'abfip' in Perl. Regex erryday.)

    if ($arg2 && $arg2 =~ m/[abfipcd]/) {
      dsay "Dereferencing reg $arg2 for program $pid";
      $arg2 = $memory_bank->{$arg2};
    }

Based on the operation, we will…well, perform it.

    switch ($op0) {

Set

      case 'set' {
        dsay "Setting $arg1 to $arg2";
        $memory_bank->{$arg1} = $arg2;
      }

Multiply

      case 'mul' {
        $memory_bank->{$arg1} *= $arg2;
      }

Add

      case 'add' {
        $memory_bank->{$arg1} += $arg2;
      }

Mod

      case 'mod' {
        $memory_bank->{$arg1} %= $arg2;
      }

Send

      case 'snd' {
        if ($arg1 =~ m/[abfipcd]/) {
          dsay "Dereferencing reg $arg1 for program $pid";
          $arg1 = $memory_bank->{$arg1};
        }
        if ($pid == 0) {
          push @q1, $arg1;
        } else {
          push @q2, $arg1;
        }
        ++$memory_bank->{'sent'};
        dsay "Queue contents are now @q1 and @q2";
      }

Receive

      case 'rcv' {
        my $q = (($pid == 1) ? \@q1 : \@q2);
        if (scalar @{$q} > 0) {
          my $tempval = shift @{$q};
          say "Received $tempval";
          $memory_bank->{$arg1} = $tempval;
          dsay "Queue contents are now @q1 and @q2";
        } else {
          dsay "Failed receive";
          return 'failed rcv';
        }
      }

Jump if Greater than Zero

We won’t increment the instruction pointer if there’s nothing to receive, instead doing a busy wait which is not great but ¯\(ツ)

      case 'jgz' {
        if ($arg1 =~ m/[abfipcd]/) {
          dsay "Dereferencing reg $arg1 for program $pid";
          $arg1 = $memory_bank->{$arg1};
        }
        if ($arg1 > 0) {
          dsay "Jumping by $arg2";
          return $memory_bank->{'ptr'} += $arg2;
        }
      }
    }

    return ++$memory_bank->{'ptr'};
  }

The main loop:

  my $testval = 0;
  while (++$testval) {

    my $r0 = execute_cycle(0);
    my $r1 = execute_cycle(1);

    if (($r0 eq 'oob' || $r0 eq 'failed rcv') &&
        ($r1 eq 'oob' || $r1 eq 'failed rcv')) {
      my $sent = $memories[1]->{'sent'};
      say "Program 1 sent $sent values";
      return;
    }

    say 'i: ', $memories[0]->{'i'}, "\t", $memories[1]->{'i'};
    say 'a: ', $memories[0]->{'a'}, "\t", $memories[1]->{'a'};
    say 'p: ', $memories[0]->{'p'}, "\t", $memories[1]->{'p'};
    say 'f: ', $memories[0]->{'f'}, "\t", $memories[1]->{'f'};
    say 'b: ', $memories[0]->{'b'}, "\t", $memories[1]->{'b'};
    say 'c: ', $memories[0]->{'c'}, "\t", $memories[1]->{'c'};
    say 'd: ', $memories[0]->{'d'}, "\t", $memories[1]->{'d'};

  }

}

Day 19

A Series of Tubes View Puzzle Solution%20Megathread

Let’s see how this goes.

sub day19 {
  use Class::Struct;

These don’t work. At all :(

  use overload '""' => 'stringify';
  use overload '+' => 'add';

Since we’re in 2D land, make a type for vectors.

  struct(Vec => [x => '$', y => '$']);

Vector maths. Very fancy.

  sub add {
    my ($a, $b) = @_;
    return new Vec(x => $a->x + $b->x, y => $a->y + $b->y);
  }

  sub negate {
    my $a = shift;
    return new Vec(x => -$a->x, y => -$a->y);
  }

  sub stringify {
    my ($self) = @_;
    return sprintf '(%s, %s)', $self->x, $self->y;
  }

Read and process input. Ye olde line split.

  my $input = input(19);
  our @lines = split "\n", $input;
  my $line = $lines[0];
  my $col = index($line, '|');
  say "Start is on column $col";

  sub at {
    my $p = shift;
    return substr($lines[$p->y], $p->x, 1);
  }

  my $pos = new Vec(x => $col, y => 0);
  my $val = '|';
  my $dir = new Vec(x => 0, y => 1);

  $pos = add($pos, new Vec(x => 0, y => 1));

  my $steps = 1 + 1; # Do not ask why, the solution does as the solution wills
  do {
    ++$steps;
    dsay stringify($pos), ": ", $val;
    if (at(add($pos, $dir)) eq ' ') {
      my $left = new Vec(x => $dir->y, y => $dir->x);
      my $right = negate($left);
      $dir = $left if at( add($pos, $left)) ne ' ';
      $dir = $right if at( add($pos, $right)) ne ' ';
    }
    $pos = add($pos, $dir);
    print $val if ($val = at $pos) =~ /[ABCDEFGHIJKLMNOPQRSTUVWXYZ]/;
  } while $val ne 'Q' && at($pos);
  say '';
  say "$steps steps";

}

Day 20

Particle Swarm View Puzzle Solution%20Megathread

sub day20 {
  use Class::Struct;

We’re now in in 3D land, make a type for vectors.

  struct(Vec3 => [x => '$', y => '$', z => '$']);

  sub vec3 {
    return new Vec3(x => shift, y => shift, z => shift);
  }

Vector maths. Very fancy.

  sub add3 {
    my ($a, $b) = @_;
    return new Vec3(
        x => $a->x + $b->x,
        y => $a->y + $b->y,
        z => $a->z + $b->z
    );
  }

  sub stringify3 {
    my ($self) = @_;
    return sprintf '(%s, %s, %s)', $self->x, $self->y, $self->z;
  }

Part 1

  my $input = input(20);
  our @lines = split "\n", $input;

We don’t actually have to simulate anything; I think, anyway. The eventual state is based on the acceleration foremost, with ties broken by velocity, then by initial position. So the idea is that we just print out something like “a-v-p”, then sort the output to find the smallest combined manhattan distance. I think, anyway.

…of course, Unix sort is immune to numbers so that part didn’t work, but eyeballing was enough to find my one particle whose acceleration had a manhattan distance of 1. For all of 30 minutes including dicking around, I’ll take it

  sub day20_part1 {
    my $i = 0;
    foreach (@lines) {
      m/p=<(-?\d+),(-?\d+),(-?\d+)>, v=<(-?\d+),(-?\d+),(-?\d+)>, a=<(-?\d+),(-?\d+),(-?\d+)>/;

      my $p = abs($1) + abs($2) + abs($3);
      my $v = abs($4) + abs($5) + abs($6);
      my $a = abs($7) + abs($8) + abs($9);
      say "$a $v $p for Particle $i";
      ++$i;
    }
  }

Part 2

This time, we do want to “simulate” particles. Collision checks and all.

  sub day20_part2 {
    my @positions = ();
    my @velocities = ();
    my @accels = ();

First, build the start state. Instead of a Particle struct I just went with 3 parallel lists.

    foreach (@lines) {
      m/p=<(-?\d+),(-?\d+),(-?\d+)>, v=<(-?\d+),(-?\d+),(-?\d+)>, a=<(-?\d+),(-?\d+),(-?\d+)>/;

      push @positions, vec3($1, $2, $3);
      push @velocities, vec3($4, $5, $6);
      push @accels, vec3($7, $8, $9);
    }

Tick ye olde kinematics.

    my $iters = 0;
    while (++$iters < 1000) {
      @velocities = pairwise { add3 $a, $b } @velocities, @accels;
      @positions = pairwise { add3 $a, $b } @positions, @velocities;

      #  Check collisions
      my %pos_hash = ();
      my $was_collision = 0;
      for my $index (0 .. $#positions) {
        my $key = stringify3 $positions[$index];
        my $prior = $pos_hash{$key};
        if ($prior) {
          $positions[$index] = $velocities[$index] = $accels[$index] = 'nope';
          $positions[$prior] = $velocities[$prior] = $accels[$prior] = 'nope';
          dprint " \nDeleted P#$index at $key which collides with P#$pos_hash{$key}";
          $was_collision = 1;
        } else {
          $pos_hash{$key} = $index;
        }
      }

      if ($was_collision) {
        @positions = grep !/nope/, @positions;
        @velocities = grep !/nope/, @velocities;
        @accels = grep !/nope/, @accels;
        my $after = scalar @positions;
        say "\n$after particles left.\n";
      }
      print "\r$iters iterations";
    }
    say '';
  } 

FIXME: Output is 658 (too high) after many many iterations (the real answer is 657). Where is my off-by-one?

  compound_solve(\&day20_part1, \&day20_part2)->(); 
}

Day 21

Fractal Art View Puzzle Solution%20Megathread

Helpers

Flip a square (vertically):

sub flip {
  return join '/', reverse(split '/', shift);
}

We don’t implement horizontal flip because we are lazy and can instead transpose after flipping to accomplish the same.


Transpose a grid.

sub transpose {

transpose visualised

  my @strs = split '/', shift;

We can safely assume, for the purposes of day 21, that our grid is either a 2x2 or a 3x3. To transpose, we respectively make either one swap, or three.

  if (scalar @strs == 2) {
    (substr($strs[0], 1, 1),
     substr($strs[1], 0, 1)) = (substr($strs[1], 0, 1),
                                substr($strs[0], 1, 1));
    return join '/', @strs;
  } # else assume 3x3 grid

  (substr($strs[0], 1, 1),
   substr($strs[1], 0, 1)) = (substr($strs[1], 0, 1),
                              substr($strs[0], 1, 1));

  (substr($strs[0], 2, 1),
   substr($strs[2], 0, 1)) = (substr($strs[2], 0, 1),
                              substr($strs[0], 2, 1));

  (substr($strs[2], 1, 1),
   substr($strs[1], 2, 1)) = (substr($strs[1], 2, 1),
                              substr($strs[2], 1, 1));

  return join '/', @strs;
}

Test

sub test_21 {
  my $in = 'ab/yz';
  my $expected = 'ay/bz';
  my $actual = transpose($in);

  print "Actual: $actual\n";
  print "Expected: $expected\n";
  say '---';

  $in = '###/.##/#..';
  $expected = '#.#/##./##.';
  $actual = transpose($in);

  print "Actual: $actual\n";
  print "Expected: $expected\n";
  say '---';

  $in = '###/#../#..';
  $expected = '###/#../#..';
  $actual = transpose($in);

  print "Actual: $actual\n";
  print "Expected: $expected\n";
}

Part 1

sub day21_part1 {
  my %rules = ();
  my $input = input 21;

Parse rules. First, of course, we line split.

  foreach my $line (split '\n', $input) {

Then we separate the input from the output of the rule, and insert it.

    my ($key, $val) = split ' => ', $line;

    $rules{$key} = $val;
    dsay "$key, $val";

Next, generate companion rules for all variations on this block from rotate/flip. This will save us having to do it on the fly for each block each iteration.

    $key = flip $key;
    $rules{$key} = $val;
    dsay "$key, $val";
    $key = transpose $key;
    $rules{$key} = $val;
    dsay "$key, $val";

    $key = flip $key;
    $rules{$key} = $val;
    dsay "$key, $val";
    $key = transpose $key;
    $rules{$key} = $val;
    dsay "$key, $val";

    $key = flip $key;
    $rules{$key} = $val;
    dsay "$key, $val";
    $key = transpose $key;
    $rules{$key} = $val;
    dsay "$key, $val";

    $key = flip $key;
    $rules{$key} = $val;
    dsay "$key, $val";
    say "Rule keys: \n", join "\n\n", map { $_ =~ s/\//\n/g; $_ } keys %rules;
  }

  my $count = scalar keys %rules;
  say "There are $count rules."
  # say "Rules: \n", join "\n\n", map { $_ =~ s/\//\n/g; $_ } keys %rules;
}

Part 2

sub day21_part2 {
  say 'yay';
}

Day 22

Sporifica Virus View Puzzle Solution%20Megathread

TODO Solve

Day 23

Coprocessor Conflagration View Puzzle Solution%20Megathread

TODO Solve

Day 24

Electromagnetic Moat View Puzzle Solution%20Megathread

TODO Solve

Day 25

The Halting Problem View Puzzle Solution%20Megathread

TODO Solve

Entry Point

I could do something clever when we run ./aoc.pl.md. But I won’t.

usage unless scalar @ARGV;

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.

/u/exploding_cat_wizard points out that we can use Getopt::Long with with the following one-liner to just do the thing. Hooray!

GetOptions('debug!' => \$DEBUG);

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 $bad_index = sub { print "I'm in ur index sploiting ur off-by-ones\n" };
my @solutions = (
  $bad_index,
  \&day1,
  \&day2,
  compound_solve(\&day3_part1, \&day3),
  compound_solve(\&day4_part1, \&day4_part2),
  \&day5,
  \&day6,
  compound_solve(\&day7, \&day7_part2),
  \&day8,
  \&day9,
  compound_solve(\&day10_part1, \&day10),
  \&day11,
  \&day12,
  \&day13,
  \&day14,
  \&day15,
  \&day16,
  compound_solve(\&day17_part1, \&day17_part2),
  compound_solve(\&day18, \&day18_part2),
  \&day19,
  \&day20,
  compound_solve(\&day21_part1, \&day21_part2),
  \&day22,
  \&day23,
  \&day24,
  \&day25,
);

We can test too. Sometimes.

sub no_test { print 'No test for this day'; }

my @tests = (
  $bad_index,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
  \&test_21,
  \&no_test,
  \&no_test,
  \&no_test,
  \&no_test,
);

day and test are the only “commands” supported here.

my $command = shift @ARGV;
if ($command eq 'day') {
  my $daynum = shift @ARGV;
  if (exists($solutions[$daynum])) {
    $solutions[$daynum]();
  }
  else {
    print "No solution for day $daynum\n";
  }
}

elsif ($command eq 'test') {
  my $daynum = shift @ARGV;
  if (exists($tests[$daynum])) {
    $tests[$daynum]();
  }
  else {
    print "No test for day $daynum\n";
  }

}

Rather than a usage, I use the convenient side-effect of the else block below…

…which allows me to type e.g. ./aoc.pl.md pants to run sloppy one-off sanity checks and such.

else {
  (my $something = join '', ('a' .. 'z')) =~ s/b/BEES/;
  say $something;
}

We Need To Go Deeper

So, I want to use Inline::Python to play with more wonderful, awful ideas. But all I can muster is this heredoc.

# doIt();
# use Inline Python => <<HERE;
# def doIt():
#   print( 'hi')
# HERE

HERE

The extra HERE is necessary to prevent my syntax highlighting from getting confused and doing nasty things. I could fix the root cause, but this way is more fun.

Supposedly, we can say use Inline Python => 'DATA'; to use what’s below, but it won’t work for me. ¯\_(ツ)_/¯

__END__

Intermission

__DATA__
__PYTHON__
def doIt():
  print( 'hi')

__C__

void doIt() { printf("Hi\n"); }

Fin~

In closing, I would just like to say, blender.stackexchange is pretty neat. Wow. The internet is a beautiful place, sometimes. (Besides when, you know, it’s not.)