AoC day 20 (pt2), Perl

#!/usr/bin/perl

use strict;
use warnings;

use List::AllUtils  qw(none indexes);

$| = 1;
$/ = '';

# Map for reversing bits of an edge
my @Rev_Map = map { oct("0b" . reverse(sprintf( "%010b", $_ ))) } (0 .. 1023);

# Read in tiles, calculate edge array (D4 group) for manipulating
my %Tiles;
my $count = 0;
while (<>) {
    my @lines = split( "\n" );
    chomp @lines;

    my ($num) = ((shift @lines) =~ m#Tile (\d+):#);

    my @tile = map { [ split( // ) ] } @lines;

    my ($ident, $rot1, $rot2, $rot3)   = (0,0,0,0);  # top, left, bottom, right
    foreach my $i (0 .. 9) {
        $ident  = ($ident << 1) | ($tile[0][$i] eq '#');
        $rot1   = ($rot1 << 1)  | ($tile[9-$i][0] eq '#');
        $rot2   = ($rot2 << 1)  | ($tile[9][9-$i] eq '#');
        $rot3   = ($rot3 << 1)  | ($tile[$i][9] eq '#');
    }

    my $flip  = $Rev_Map[ $rot1  ];
    my $flip1 = $Rev_Map[ $ident ];
    my $flip2 = $Rev_Map[ $rot3  ];
    my $flip3 = $Rev_Map[ $rot2  ];

    foreach my $y (1 .. 8) {
        foreach my $x (1 .. 8) {
            $count++ if ($tile[$y][$x] eq '#');
        }
    }

    $Tiles{$num}{edge} = [ $ident, $rot1, $rot2, $rot3, $flip, $flip1, $flip2, $flip3 ];
    $Tiles{$num}{tile} = \@tile;
}

print "Hashes in image: $count\n";

# Match up tiles to sort out corners from rest
my @Side_Map = ( 0, 1, 2, 3, 1, 0, 3, 2 );
my @tlist = keys %Tiles;
my $Dim = sqrt( scalar @tlist );

my %Match;
foreach my $t1 (0 .. $#tlist) {
    foreach my $t2 ($t1 + 1 .. $#tlist) {
        foreach my $i (0 .. 7) {
            my $s1 = $Tiles{$tlist[$t1]}{edge}[$i];

            foreach my $j (0 .. 7) {
                my $s2 = $Tiles{$tlist[$t2]}{edge}[$j];

                if ($s1 == $s2) {
                    $Match{$tlist[$t1]}{$tlist[$t2]} = $i;
                    $Match{$tlist[$t2]}{$tlist[$t1]} = $j;
                }
            }
        }
    }
}


# Put together unoriented tiles in Image
my @Image;
my %Info;

sub set_cell {
    my ($y, $x, $tile) = @_;

    warn "Tile already used ($tile)\n"  if ($Info{$tile}{used});
    $Image[$y][$x] = $tile;
    $Info{$tile}{used} = 1;
}

# Find a corner to start at while recording neighbours into info hash
my $corner_start;
foreach my $k (keys %Match) {
    my $neigh = keys %{$Match{$k}};
    $Info{$k}{neigh} = $neigh;
    $corner_start = $k  if ($neigh == 2);
}

&set_cell( 0, 0, $corner_start );

# Init the one on the next row so it is marked used
my $cell = (keys %{$Match{$corner_start}})[0];
&set_cell( 1, 0, $cell );

# Start by building upper edge
foreach my $x (1 .. $Dim - 2) {
    my $prev = $Image[0][$x - 1];
    my @neigh = keys %{$Match{$prev}};

    foreach my $i (@neigh) {
        next if ($Info{$i}{used});

        if ($Info{$i}{neigh} == 3) {
            &set_cell( 0, $x, $i );
        } elsif ($Info{$i}{neigh} == 4) {
            &set_cell( 1, $x - 1, $i );
        }
    }
}my $up_right;
foreach my $i (keys %{$Match{$Image[0][$Dim - 2]}}) {
    next if ($Info{$i}{used});
    $up_right = $i  if ($Info{$i}{neigh} == 2);
}

&set_cell( 0, $Dim - 1, $up_right );


# Build right edge
foreach my $y (1 .. $Dim - 2) {
    my $prev = $Image[$y - 1][0];
    my @neigh = keys %{$Match{$prev}};

    foreach my $i (@neigh) {
        next if ($Info{$i}{used});

        if ($Info{$i}{neigh} == 3) {
            &set_cell( $y, 0, $i );
        } elsif ($Info{$i}{neigh} == 4) {
            &set_cell( $y - 1, 1, $i );
        }
    }
}

# Build the rest
foreach my $y (1 .. $Dim - 1) {
    foreach my $x (0 .. $Dim - 1) {
        next if (defined $Image[$y][$x]);

        my $north = $Image[$y - 1][$x];

        my @unmatched = grep { !$Info{$_}{used} } keys %{$Match{$north}};
        if (scalar @unmatched != 1) {
            if (@unmatched) {
                warn "Warning: Unmatched $north: ", join( ', ', @unmatched ), "\n";
            } else {
                warn "Warning: Unmatched $north: empty!\n";
            }
        } else {
            &set_cell( $y, $x, $unmatched[0] );
        }
    }
}

print "\nImage:\n";
foreach my $y (0 .. $Dim - 1) {
    foreach my $x (0 .. $Dim - 1) {
        if (!defined $Image[$y][$x]) {
            print "xxxx ";
        } else {
            print "$Image[$y][$x] ";
        }
    }
    print "\n";
}

#
#  Helper functions for manipulating tiles:
#
sub print_tile {
    my $cell = shift;

    my @tile = @{$cell->{tile}};
    my @edge = @{$cell->{edge}};

    foreach my $y (0 .. 9) {
        foreach my $x (0 .. 9) {
            print $tile[$y][$x];
        }
        print "\n";
    }

    print "Edges: [", join( ',', @edge ), "]\n";
    foreach my $i (0 .. 3) {
        printf( "$i [%3d]: %010b    %d [%3d]: %010b\n",
                $edge[$i], $edge[$i], $i+4, $edge[$i+4], $edge[$i+4] );
    }
}


sub flip_tile {
    my $cell = shift;

    my @tile = @{$cell->{tile}};
    my @edge = @{$cell->{edge}};

    my @flip;
    foreach my $y (0 .. 9) {
        foreach my $x (0 .. 9) {
            $flip[$x][$y] = $tile[$y][$x];
        }
    }

    my @e_flip;
    foreach my $i (0 .. 7) {
        $e_flip[$i] = $edge[($i + 4) % 8];
    }

    return ('edge' => \@e_flip, 'tile' => \@flip);
}

sub rotate_tile {
    my $cell = shift;
    my $num  = shift;

    return (%$cell)  if ($num == 0);

    my @tile = @{$cell->{tile}};
    my @edge = @{$cell->{edge}};

    my @rot;
    foreach my $y (0 .. 9) {
        foreach my $x (0 .. 9) {
            $rot[$y][$x] = $tile[9-$x][$y];
        }
    }

    my @e_rot;
    foreach my $i (0 .. 3) {
        $e_rot[$i] = $edge[($i + 1) % 4];
        $e_rot[$i + 4] = $edge[($i - 1) % 4 + 4];
    }

    $num--;
    &rotate_tile( {'edge' => \@e_rot, 'tile' => \@rot}, $num );
}

# detect which sides of first corner tile don't connect:
my %corn_sides = ( 0 => 1, 1 => 1, 2 => 1, 3 => 1 );
foreach my $i (keys %{$Match{$corner_start}}) {
    delete $corn_sides{ $Side_Map[$Match{$corner_start}{$i}] };
}

my @missing = sort { $a <=> $b } keys %corn_sides;
if (scalar( keys %corn_sides ) != 2) {
    die "Corner does not have two missing sides!\n";
}

my $rots_needed = $missing[0];
if ($rots_needed == 0 && $missing[1] == 3) {
    $rots_needed = 3;
}

my %rot_corner = &rotate_tile( $Tiles{$Image[0][0]}, $rots_needed );

# Rotating the blanks to the outside might not be enough,
# we might need to flip it over too.
if (none { $_ == $rot_corner{edge}[3] } @{$Tiles{$Image[0][1]}{edge}}) {
    %rot_corner = &flip_tile( \%rot_corner );
}

#
# Putting together correctly rotated tiles:
#
my @Map;
$Map[0][0] = \%rot_corner;

# build top edge by orienting to connect to left
foreach my $i (1 .. $Dim - 1) {
    my $need_left = $Rev_Map[ $Map[0][$i - 1]{edge}[3] ];

    my %next_tile = %{$Tiles{$Image[0][$i]}};
    my ($targ_pos) = indexes { $_ == $need_left } @{$next_tile{edge}};
    if ($targ_pos >= 4) {
        %next_tile = &flip_tile( \%next_tile );
        $targ_pos -= 4;
    }

    %next_tile = &rotate_tile( \%next_tile, ($targ_pos + 3) % 4 );
    $Map[0][$i] = \%next_tile;
}

# build rest by orienting to connect to top
foreach my $y (1 .. $Dim - 1) {
    foreach my $x (0 .. $Dim - 1) {
        my $need_top = $Rev_Map[ $Map[$y - 1][$x]{edge}[2] ];

        my %next_tile = %{$Tiles{$Image[$y][$x]}};

        my ($targ_pos) = indexes { $_ == $need_top } @{$next_tile{edge}};
        if ($targ_pos >= 4) {
            %next_tile = &flip_tile( \%next_tile );
            $targ_pos -= 4;
        }

        %next_tile = &rotate_tile( \%next_tile, $targ_pos );
        $Map[$y][$x] = \%next_tile;
    }
}

#
# Stitch together image as arrays of strings in four orientations:
#   - as made + its reverse, by columns + its reverse
#
my @Stitch;
foreach my $y (0 .. $Dim - 1) {
    foreach my $ty (1 .. 8) {
        my $line = $y * 8 + ($ty - 1);
        $Stitch[0][$line] = '';
        $Stitch[1][$line] = '';
        foreach my $x (0 .. $Dim - 1) {
            foreach my $tx (1 .. 8) {
                $Stitch[0][$line] .= $Map[$y][$x]{tile}[$ty][$tx];
                $Stitch[1][$line] .= $Map[$x][$y]{tile}[$tx][$ty];
            }
        }
    }
}

foreach my $m (0 .. 1) {
    foreach my $line (@{$Stitch[$m]}) {
        my $rev = reverse( $line );
        push( @{$Stitch[$m + 2]}, $rev );
    }
}

# Using the middle line of a monster to get best map.
# Assuming that the best match of these is correct.
# For my input, the others have 0, 0, and 2 hits.
my $best;
my @hits;
foreach my $i (0 .. 3) {
    my @matches = indexes { m/#....##....##....###/ } @{$Stitch[$i]};
    if (@matches > @hits) {
        $best = $i;
        @hits = @matches;
    }
}

print "\nBest orientation: $best\n";
print "Lines with hits: ", join( ',', @hits ), "\n\n";
foreach my $line (@{$Stitch[$best]}) {
    print "$line\n";
}

# Two remaining orientations to detect: up-side-up or up-side-down monsters
my $up_side   = 0;
my $down_side = 0;

foreach my $i (@hits) {
    next if ($i == 0 || $i == scalar($Stitch[$best]) - 1);

    my $line = $Stitch[$best][$i];
    while ($line =~ m/#....##....##....###/g) {
        my $x_end = pos( $line );

        if (substr( $Stitch[$best][$i-1], $x_end - 2, 1 ) eq '#') {
            my $lower = substr( $Stitch[$best][$i+1], $x_end - 19, 16 );
            if ($lower =~ m/^#..#..#..#..#..#/) {
                $up_side++;
            }
        }

        if (substr( $Stitch[$best][$i+1], $x_end - 2, 1 ) eq '#') {
            my $upper = substr( $Stitch[$best][$i-1], $x_end - 19, 16 );
            if ($upper =~ m/^#..#..#..#..#..#/) {
                $down_side++;
            }
        }
    }
}

print "\nSeamonsters found Up-side-up: $up_side\n";
print "Seamonsters fOund Up-side-dOwn: $down_side\n";

# Assuming no overlapping seamonsters
print "Part 2: ", $count - 15 * ($up_side || $down_side), "\n";