AoC 2021 day 19 (Perl)

#!/usr/bin/perl

use strict;
use warnings;

use List::AllUtils  qw(sum max true pairwise all firstidx onlyval);

$; = ',';
$/ = '';

# Table of rotations (maybe write code to build this instead?)
my @Rot = ( [[ 1, 0, 0], [ 0, 1, 0], [ 0, 0, 1]],
            [[ 1, 0, 0], [ 0, 0, 1], [ 0,-1, 0]],
            [[ 1, 0, 0], [ 0,-1, 0], [ 0, 0,-1]],
            [[ 1, 0, 0], [ 0, 0,-1], [ 0, 1, 0]],

            [[-1, 0, 0], [ 0, 0, 1], [ 0, 1, 0]],
            [[-1, 0, 0], [ 0, 1, 0], [ 0, 0,-1]],
            [[-1, 0, 0], [ 0, 0,-1], [ 0,-1, 0]],
            [[-1, 0, 0], [ 0,-1, 0], [ 0, 0, 1]],

            [[ 0, 1, 0], [ 0, 0, 1], [ 1, 0, 0]],
            [[ 0, 1, 0], [ 1, 0, 0], [ 0, 0,-1]],
            [[ 0, 1, 0], [ 0, 0,-1], [-1, 0, 0]],
            [[ 0, 1, 0], [-1, 0, 0], [ 0, 0, 1]],

            [[ 0,-1, 0], [ 1, 0, 0], [ 0, 0, 1]],
            [[ 0,-1, 0], [ 0, 0, 1], [-1, 0, 0]],
            [[ 0,-1, 0], [-1, 0, 0], [ 0, 0,-1]],
            [[ 0,-1, 0], [ 0, 0,-1], [ 1, 0, 0]],

            [[ 0, 0, 1], [ 1, 0, 0], [ 0, 1, 0]],
            [[ 0, 0, 1], [ 0, 1, 0], [-1, 0, 0]],
            [[ 0, 0, 1], [-1, 0, 0], [ 0,-1, 0]],
            [[ 0, 0, 1], [ 0,-1, 0], [ 1, 0, 0]],

            [[ 0, 0,-1], [ 0, 1, 0], [ 1, 0, 0]],
            [[ 0, 0,-1], [ 1, 0, 0], [ 0,-1, 0]],
            [[ 0, 0,-1], [ 0,-1, 0], [-1, 0, 0]],
            [[ 0, 0,-1], [-1, 0, 0], [ 0, 1, 0]] );

#
# Vector and matrix arithmetic functions
#
sub vecmatrix_mult (\@\@) {
    my ($vec, $mat) = @_;
    return ([map { sum pairwise { $a * $b } @$vec, @$_ } @$mat]);
}

sub vec_add (\@\@) {
    my ($v, $w) = @_;
    return ([pairwise { $a + $b } @$v, @$w]);
}

sub vec_subtract (\@\@) {
    my ($v, $w) = @_;
    return ([pairwise { $a - $b } @$v, @$w]);
}

sub vec_equal (\@\@) {
    my ($v, $w) = @_;
    return (@$v == sum pairwise { $a == $b } @$v, @$w);
}

sub grid_distance (\@\@) {
    my ($p, $q) = @_;
    return (sum pairwise { abs( $a - $b ) } @$p, @$q);
}

sub euclid_distance (\@\@) {
    my ($p, $q) = @_;
    return (sum pairwise { ($a - $b) ** 2 } @$p, @$q);
}


#
#  Mainline: Read in data
#
my @Scan;           # Array of vectors, scanners -> beacon vectors

while (<>) {
    my @lines = split( /\n/, $_ );

    my $head = shift( @lines );
    my ($i) = ($head =~ m#scanner (\d+)#);

    $Scan[$i]->@* = map { [split /,/] } @lines;
}

#  Build table to use square-of-Euclidean-distances as a hash to detect overlaps
#
#  Note: Test and my input have unique distances for each pair in a scanner block,
#        so we're going to assume that and just use a pair instead of a list of pairs.
#
my @Dist_hash;      # Array of hash of array pair, scanner -> distance -> indices of beacons

foreach my $s (0 .. $#Scan) {
    foreach my $i (0 .. $Scan[$s]->$#* - 1) {
        foreach my $j ($i + 1 .. $Scan[$s]->$#*) {
            next if ($i == $j);

            my $d = &euclid_distance( $Scan[$s][$i], $Scan[$s][$j] );

            $Dist_hash[$s]{$d} = [$i,$j];
        }
    }
}

#  Build Graph
#
#  Overlaps have at least triangle(11) equal distances.  One pair of scanners in my data
#  has 67 equal distances (each scanner has a match not part of the complete K12 graph).
#  This is the only non-triangular number of counts in my input.  This suggests that it
#  might be a monkey wrench intentionally thrown in by the input generator.  We'll deal
#  this that when we actually build mappings and can see what's not in K12.
#
my @Graph;          # Array of lists, scanner -> list of overlapping scanners (symmetric)

foreach my $s (0 .. $#Scan - 1) {
    foreach my $t ($s + 1 .. $#Scan) {
        my $count = true {exists $Dist_hash[$t]{$_}} keys %{$Dist_hash[$s]};

        if ($count >= 66) {    # triangle(11)
            push( @{$Graph[$s]}, $t );
            push( @{$Graph[$t]}, $s );
        }
    }
}

#
# Function to shift the frame of the beacons of scanner #t into the frame of scanner #s.
# Returns position of scanner (ie origin of t in the frame of s)
#
sub frame_shift {
    my ($s,$t) = @_;

    # Build map of scan-s beacon indices to scan-t beacon indices
    #
    # Start by building a sparse array mapping (scan-s indices, scan-t indices) to
    # the count of the number of times those indices match on a distance. The valid
    # mapping between the indices scan-s to scan-t is therefore the ones which equal 11.
    my %map_table;
    foreach my $sd (keys %{$Dist_hash[$s]}) {
        foreach my $i (@{$Dist_hash[$s]{$sd}}) {
            foreach my $j (@{$Dist_hash[$t]{$sd}}) {
                $map_table{$i,$j}++;
            }
        }
    }

    # Condense sparse map
    my %map = map {($map_table{$_} == 11) ? (split($;, $_)) : ()} keys %map_table;

    #
    # Find rotation that maps points from t onto s
    #
    my @sidx = keys %map;

    # parallel arrays of beacons that are in both
    my @spt = map { [ @{$Scan[$s][$_]} ]       } @sidx;
    my @tpt = map { [ @{$Scan[$t][$map{$_}]} ] } @sidx;

    # find rotation by making pt 1 relative to pt 0, then trying them
    my $srel = &vec_subtract( $spt[1], $spt[0] );
    my $trel = &vec_subtract( $tpt[1], $tpt[0] );

    my $r = firstidx { &vec_equal( &vecmatrix_mult($trel, $_), $srel ) } @Rot;

    # transform is: get relative to t[0] by subtraction, mult to rotate, then add s[0] to shift
    my $trans = sub { &vec_add( &vecmatrix_mult( &vec_subtract(shift, $tpt[0]), $Rot[$r] ), $spt[0]) };

    # Do transposition
    foreach my $i (0 .. $Scan[$t]->$#*) {
        # just copy coords from s that are already in t
        my $si = onlyval { $map{$_} == $i } keys %map;

        $Scan[$t][$i] = (defined $si) ? $Scan[$s][$si] : &$trans( $Scan[$t][$i] );
    }

    return (&$trans([0,0,0]));
}

#
# Finally, progressively merge scanners into the frame of scanner #0
#

# Scanner positions in the frame of scanner #0
my @Scan_pos = ([0,0,0]);

# Job queue to process merges, start by queuing up everything from scanner #0
my @queue  = map { [0,$_] } @{$Graph[0]};
my @merged = (1, (0) x ($#Scan - 1));

while (my $job = shift @queue) {
    next if ($merged[$job->[1]]++);

    $Scan_pos[$job->[1]] = &frame_shift( @$job );

    # Push merging of neighbours of newly merged scanner into then queue
    push( @queue, map { [$job->[1],$_] } @{$Graph[$job->[1]]} );
}

# Build set of unique beacon coords
my %Beacons = map {my $scan = $_; map { join($;, @$_) => 1 } @$scan} @Scan;

print "Part 1: ", scalar keys %Beacons, "\n";

# Find max distance between two scanners
my $max_dist = max map {my $s = $_; map { &grid_distance($s, $_) } @Scan_pos} @Scan_pos;

print "Part 2: $max_dist\n";