AoC 2023 day 22 (Perl)

#!/usr/bin/perl

use strict;
use warnings;

use feature         qw(say);
use List::AllUtils  qw(all max min uniqint);

$| = 1;

# Read in pieces:
my @Piece;
while (<>) {
    my @ends = map {[map {int} m#(\d+)#g]} m#(.*)~(.*)#;

    my @delta = map {$ends[1][$_] - $ends[0][$_]} (0 .. 2);
    my @step  = map {$ends[1][$_] <=> $ends[0][$_]} (0 .. 2);

    my $height = min( $ends[0][2], $ends[1][2] );
    my $top = abs( $ends[1][2] - $ends[0][2] ) + 1;
    my $len = max( @delta ) + 1;

    my @block;          # mask of piece cubes
    my @bottom;         # (x,y) coordinates of cubes on the bottom layer

    my @pos = $ends[0]->@*;
    $pos[2] -= $height;

    for (my $i = 0; $i < $len; $i++) {
        push( @block, [@pos] );
        push( @bottom, [$pos[0],$pos[1]] ) if ($pos[2] == 0);
        @pos = map { $pos[$_] += $step[$_] } (0 .. 2);
    }

    push( @Piece, {height => $height, block => \@block, bottom => \@bottom, top => $top} );
}

# Sort pieces by height and drop to form tower and build support graph.
@Piece = sort { $a->{height} <=> $b->{height} } @Piece;

my %Tower;
my %Tops;
my @Support;
for (my $i = 0; $i < @Piece; $i++) {
    my %piece = $Piece[$i]->%*;

    # Drop piece until it intersects the top of the tower:
    my @intersect;
    my $h = $piece{height};

    DROP:
    while ($h > 0) {
        @intersect = grep { $h <= ($Tops{join($;, @$_)} // 0) } $piece{bottom}->@*;
        last DROP if (@intersect);
        $h--;
    }

    # Get supporing pieces and link in graph:
    my @supp = uniqint map { $Tower{$_->[0],$_->[1],$h} } @intersect;

    push( $Support[$i]{below}->@*, @supp );
    push( $Support[$_]{above}->@*, $i ) foreach (@supp);

    # Update (x,y) tops of the tower:
    foreach my $xy ($piece{bottom}->@*) {
        $Tops{join($;,@$xy)} = $h + $piece{top};
    }

    # Add piece to Tower (coord => piece id).
    foreach my $cube ($piece{block}->@*) {
        $Tower{ $cube->[0], $cube->[1], $cube->[2] + $h + 1 } = $i;
    }
}

# Use support graph to get answers for part 1 and 2:
my $part1 = 0;
my $part2 = 0;
for (my $i = 0; $i < @Piece; $i++) {
    print ::stderr "Piece: $i / $#Piece\r";
    if (!defined $Support[$i]{above} or (all {$Support[$_]{below}->@* > 1} $Support[$i]{above}->@*)) {
        $part1++;
        next;
    }

    # Brute forcing part 2 with a queue:
    my %falls = ($i => 1);
    my @queue = $Support[$i]{above}->@*;

    while (my $p = shift @queue) {
        if (all { $falls{$_} } $Support[$p]{below}->@*) {
            $falls{$p} = 1;
            push( @queue, $Support[$p]{above}->@* ) if (defined $Support[$p]{above});
        }
    }

    $part2 += %falls - 1;       # -1 for the block we removed
}

say "\nPart 1: $part1";
say "Part 2: $part2";