Advent of Code 2021 solutions

These are my solutions for this year's contest.

Main page on my blog.

If you want to copy these files, use the GitHub link.

All files covered by the UNLICENSE.

Table of contents

Advent of Code 2021 day 1 - Sonar Sweep

[ AoC problem link ] [ Discussion ].

Day 01 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/reduce/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my %ans;

# Part 1: use `reduce` here just because we can
# $a and $b are set to the initial entries in the list, then $a is set
# to the result. So we return $b last
my $res = reduce {
    if ( $b > $a ) { $ans{1}++ }
    $b
} @input;

# Part 2: our requirement: d[i]+d[i+1]+d[i+2] < d[i+1]+d[i+2]+d[i+3]
#         this reduces to:             d[i+3] > d[i]
for my $idx ( 0 .. $#input - 3 ) {
    $ans{2}++ if ( $input[ $idx + 3 ] > $input[ $idx  ] );
}

### FINALIZE - tests and run time
is( $ans{1}, 1655, "Part 1: $ans{1}" );
is( $ans{2}, 1683, "Part 2: $ans{2}" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms { my ($s) = @_;
    return sprintf("Duration: %02dh%02dm%02ds (%.3f ms)",
    int($s/(60*60)),($s/60)%60,$s%60,$s*1000);
}

27 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 2 - Dive!

[ AoC problem link ] [ Discussion ].

Day 02 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $file = $testing ? 'test.txt' : 'input.txt';
### CODE
my %pos = (
    1 => { x => 0, y => 0 },
    2 => { x => 0, y => 0, aim => 0 }
);

my %actions = (
    forward => sub {
        $pos{1}->{x} += $_[0];
        $pos{2}->{x} += $_[0];
        $pos{2}->{y} += $_[0] * $pos{2}->{aim};
    },
    down => sub { $pos{1}->{y} += $_[0]; $pos{2}->{aim} += $_[0] },
    up   => sub { $pos{1}->{y} -= $_[0]; $pos{2}->{aim} -= $_[0] }
);

open( my $fh, '<', "$file" );
while (<$fh>) {
    chomp;
    s/\r//gm;
    my ( $cmd, $amt ) = split( / /, $_ );
    if ( exists $actions{$cmd} ) {
        $actions{$cmd}->($amt);
    }
    else {
        warn "unknown command: $cmd";
    }
}

my $part1 = $pos{1}->{x} * $pos{1}->{y};
my $part2 = $pos{2}->{x} * $pos{2}->{y};
### FINALIZE - tests and run time
is( $part1, 1714680,    "Part 1: $part1" );
is( $part2, 1963088820, "Part 2: $part2" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {  
    my ($s) = @_;
    return sprintf("Duration: %02dh%02dm%02ds (%.3f ms)",
    int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

43 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 3 - Binary Diagnostic

[ AoC problem link ] [ Discussion ].

Day 03 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
use utf8;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
my @data;
my %freq;

while (<$fh>) {
    chomp; s/\r//gm;
    my @values = split(//, $_);
    push @data, \@values;
    map { $freq{$_}->{ $values[$_] }++ } ( 0 .. $#values );
}

### CODE
sub filter_by_index_and_type;
## Part 1

my ( $𝛾, $ε );
for my $i ( 0 .. ( scalar keys %freq ) - 1 ) {
    if ( $freq{$i}->{0} > $freq{$i}->{1} ) {
        $𝛾 .= 0;
        $ε .= 1;
    }
    elsif ( $freq{$i}->{1} > $freq{$i}->{0} ) {
        $𝛾 .= 1;
        $ε .= 0;
    }
}
my $part1 = oct( "0b" . $𝛾 ) * oct( "0b" . $ε );

## Part 2

# initial setup, mark all rows as valid
my $oxy = { map { $_ => 1 } ( 0 .. $#data ) };
my $cdx = { map { $_ => 1 } ( 0 .. $#data ) };

# for each column, filter those entries that match the condition
for my $idx ( 0 .. scalar @{ $data[0] } - 1 ) {
    $oxy = filter_by_index_and_type( $idx, 'oxy', $oxy );
    $cdx = filter_by_index_and_type( $idx, 'cdx', $cdx );
}
my $part2 = oct( "0b" . join( '', @{ $data[ ( keys %$oxy )[0] ] } ) ) *
            oct( "0b" . join( '', @{ $data[ ( keys %$cdx )[0] ] } ) );

### FINALIZE - tests and run time
is( $part1, 2003336, "Part 1: $part1" );
is( $part2, 1877139, "Part 2: $part2" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub filter_by_index_and_type {
    my ( $idx, $type, $filter ) = @_;
    my $new_filter;
    my @col;
    # select those rows that match the incoming filter
    for my $i ( keys %$filter ) {
        push @col, $data[$i]->[$idx];
    }
    # select number of 1s and 0s
    my @vals;
    $vals[0] = grep { $_ == 0 } @col;
    $vals[1] = grep { $_ == 1 } @col;
    my $common;
    if ( $type eq 'oxy' ) {
        $common = $vals[1] >= $vals[0] ? 1 : 0;
    }
    elsif ( $type eq 'cdx' ) {
        $common = $vals[0] <= $vals[1] ? 0 : 1;
    }
    else {
        die "unknown type: $type";
    }
    if ( scalar keys %$filter == 1 ) {
        return $filter;
    }
    else { # construct a new filter based on common values 
        map { $new_filter->{$_}++ if $data[$_][$idx] == $common }
            keys %$filter;
    }

    return $new_filter;
}
sub sec_to_hms {  
    my ($s) = @_;
    return sprintf("Duration: %02dh%02dm%02ds (%.3f ms)",
    int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

79 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 4 - Giant Squid

[ AoC problem link ] [ Discussion ].

Day 04 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
{
    local $/ = "";
    while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
}

### CODE
my @draws;
my %boards;
my %positions;
my %ans;
my $count = 0;
for my $chunk (@input) {
    if ( $count == 0 ) {    # first line is draws
        @draws = split( /,/, $chunk );
    }
    else {
        my @rows  = split( /\n/, $chunk );
        my $row = 1;
        for my $r (@rows) {
            my @cols  = split( " ", $r );
            my $col = 1;
            for my $number (@cols) {
                $boards{$count}{$row}{$col} = { number => $number };
                $positions{$number}{$count}{$row}{$col} = 1;
                $col++;
            }
            $row++;
        }
    }
    $count++;
}
sub calculate_board;
sub dump_board;
# initialize the %has_won hash with zeros
my %has_won = map { $_ => 0 } keys %boards;
my %visited= ();
while (@draws) {
    my $draw = shift @draws;
    for my $board ( keys %{ $positions{$draw} } ) {
	$visited{$board}++;
        for my $row ( keys %{ $positions{$draw}{$board} } ) {
            for my $col ( keys %{ $positions{$draw}{$board}{$row} } ) {
                $boards{$board}{$row}{$col}{marked}++;
            }
        }
    }
    # use the %visited hash to only scan those boards that have had a
    #number marked
    # this was implemented as an optimization but it does not seem to
    # do much
    for my $board (keys %visited ) { 

        # check rows
        for my $row ( 1 .. 5 ) {
            my $marked_count = 0;
            for my $col ( 1 .. 5 ) {
                $marked_count++ if $boards{$board}{$row}{$col}{marked};
            }
            if ( $marked_count == 5 ) {
                 $has_won{$board}++;
            }
        }

        # check columns
        for my $col ( 1 .. 5 ) {
            my $marked_count = 0;
            for my $row ( 1 .. 5 ) {
                $marked_count++ if $boards{$board}{$row}{$col}{marked};
            }
            if ( $marked_count == 5 ) {
                 $has_won{$board}++;
            }
        }
    }
    # what is the number of wins? 
    my %reverse = reverse %has_won;
    # either only 1 or 0 wins == first board
    if ( scalar keys %reverse == 2 and exists $reverse{1} ) {
        say "First board to win: draw $draw led to win on " . $reverse{1};
        $ans{1} = $draw * calculate_board( $reverse{1} );

    }
    # every board has won at least once
    elsif ( !exists $reverse{0} ) {
	# get the board with least wins (and hope it's unique)
        my $last_won
            = ( sort { $has_won{$a} <=> $has_won{$b} } keys %has_won )[0];
        say "Final board to win: draw $draw led to win on " . $last_won;
        $ans{2} = $draw * calculate_board($last_won);
        last;
    }
}

### FINALIZE - tests and run time
is( $ans{1}, 8442, "Part 1: " . $ans{1} );
is( $ans{2}, 4590, "Part 2: " . $ans{2} );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub calculate_board {
    my ($b) = @_;
    my $sum = 0;
    for my $r ( keys %{ $boards{$b} } ) {
        for my $c ( keys %{ $boards{$b}{$r} } ) {
            $sum += $boards{$b}{$r}{$c}{number}
                unless $boards{$b}{$r}{$c}{marked};
        }
    }
    return $sum;
}

sub dump_board {
    my ($b) = @_;
    for my $r ( 1 .. 5 ) {
        for my $c ( 1 .. 5 ) {
            my $num = $boards{$b}{$r}{$c}{number};
            my $string;
            if ( $boards{$b}{$r}{$c}{marked} ) {
                $string = "[$num]";
            }
            else {
                $string = $num;
            }
            printf "%4s", $string;
        }
        print "\n";
    }
}

136 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 5 - Hydrothermal Venture

[ AoC problem link ] [ Discussion ].

Day 05 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/max/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
use Math::Trig;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $part2   = shift @ARGV // 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my @lines;
my %freq;
my ( $x1, $y1, $x2, $y2 );
for my $in (@input) {
    if ( $in =~ m/^(\d+),(\d+) -> (\d+),(\d+)$/ ) {
        ( $x1, $y1, $x2, $y2 ) = ( $1, $2, $3, $4 );
    }
    else {
        die "can't parse line: $in";
    }
    my $norm_x = $x2 - $x1;
    my $norm_y = $y2 - $y1;
    my $dir    = rad2deg( atan2( $norm_y, $norm_x ) );
    # normalize degrees to between 0 and 360, because we want to use
    # them as hash keys and negative values don't work there
    $dir = $dir < 0 ? 360 + $dir : $dir;
    $freq{$dir}++;
    push @lines, {x1 => $x1, y1 => $y1, x2 => $x2, y2 => $y2, dir => $dir};
}

#dump %freq;
my $Map;
sub dump_map;
sub paint;

# note we are dealing with a coordinate system that is "flipped"
# around the X-axis. Positive Y points down
my %vectors = ( 0=>[ 1, 0], 180=>[-1, 0],  90=>[ 0, 1], 270=>[ 0, -1],
	       45=>[ 1, 1], 135=>[-1, 1], 315=>[ 1,-1], 225=>[-1,- 1]);
my %part1_dirs = ( 0 => 1, 90 => 1, 180 => 1, 270 => 1 );

for my $L (@lines) {
    my $dir = $L->{dir};
    if ( !$part2 and !exists $part1_dirs{$dir} ) {next}
    paint( $L );
}

my $count;
for my $x ( keys %$Map ) {
    for my $y ( keys %{ $Map->{$x} } ) {
        $count++ if $Map->{$x}{$y} >= 2;
    }
}
dump_map if $testing;
my $ans = $count;
if ($part2) { is( $ans, 18442, "Part 2: $ans" ) }
       else { is( $ans,  4745, "Part 1: $ans" ) }

done_testing;
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}
sub paint {
    my ($L) = @_;
    my $steps = max( abs( $L->{x2} - $L->{x1} ), abs( $L->{y2} - $L->{y1} ) );
    for ( my $i = 0; $i <= $steps; $i++ ) {
        $Map->{ $L->{x1} + $i * $vectors{ $L->{dir} }->[0] }
            ->{ $L->{y1} + $i * $vectors{ $L->{dir} }->[1] }++;
    }
}

sub dump_map {
    my ( $max_x, $max_y ) = ( -1,     -1 );
    my ( $min_x, $min_y ) = ( 10_000, 10_000 );
    for my $x ( keys %$Map ) {
        if ( $x > $max_x ) {
            $max_x = $x;
        }
        if ( $x < $min_x ) {
            $min_x = $x;
        }
        for my $y ( keys %{ $Map->{$x} } ) {
            if ( $y > $max_y ) {
                $max_y = $y;
            }
            if ( $y < $min_y ) {
                $min_y = $y;
            }
        }
    }

    for my $y ( $min_y .. $max_y ) {
        for my $x ( $min_x .. $max_x ) {
            print $Map->{$x}{$y} ? $Map->{$x}{$y} : '.';
        }
        print "\n";
    }
}

98 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 6 - Lanternfish

[ AoC problem link ] [ Discussion ].

Day 06 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $part2   = shift @ARGV // 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my %generations;
for my $f ( split( ',', $input[0] ) ) {
    $generations{$f}++;
}
sub dump_state;
my $days  = 1;
my $limit = $part2 ? 256 : 80;
while ( $days <= $limit ) {
    my %new = ();
    for my $cohort ( sort keys %generations ) {
        if ( $cohort == 0 ) {
            $new{6} = $generations{0};
            $new{8} = $generations{0};
        }
        else {
            $new{ $cohort - 1 } += $generations{$cohort};
        }
    }
    %generations = %new;
    $days++;
}
my $ans = 0;
for my $cohort ( keys %generations ) {
    $ans += $generations{$cohort};
}
if ($part2) { is( $ans, 1617359101538, "Part 2: $ans" ) }
       else { is( $ans,        356190, "Part 1: $ans" ) }
### FINALIZE - tests and run time
# is();
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub dump_state {
    my ($state) = @_;
    for my $c ( sort { $a <=> $b } keys %$state ) {
        printf( "%2d: %3d ", $c, $state->{$c} );
    }
    print "\n";
}

56 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 7 - The Treachery of Whales

[ AoC problem link ] [ Discussion ].

Day 07 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum min max/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my @positions = split( ',', $input[0] );
sub median;
sub cost_per_position;
my $median  = median(@positions);
my $average = ( sum @positions ) / scalar @positions;

# this is an optimization, instead of checking every possible position
# we just search around the range of [median,int(average)], as in my
# case these values are the solutions for part 1 and part 2
# respectively

my %ans = ( 1 => 1e10, 2 => 10e10 );
for my $t (min($median, int $average) - 5 .. max($median, int $average) + 5) {
    my $res = cost_per_position($t);
    # check if result is smaller than what we already have
    map { $ans{$_} = $res->[$_-1] < $ans{$_} ? $res->[$_-1] : $ans{$_}} (1,2);
}

### FINALIZE - tests and run time
is( $ans{1}, 337488,   "Part 1: " . $ans{1} );
is( $ans{2}, 89647695, "Part 2: " . $ans{2} );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub median {    # https://www.perlmonks.org/?node_id=90772
    my @sorted = sort { $a <=> $b } @_;
    ( $sorted[ $#sorted / 2 + 0.1 ] + $sorted[ $#sorted / 2 + 0.6 ] ) / 2;
}

sub cost_per_position {
    my ($goal) = @_;
    my @costs = ( 0, 0 );
    for my $p (@positions) {
        my $d = abs( $goal - $p );
	# part 1
        $costs[0] += $d;
	# part 2
        $costs[1] += $d * ( $d + 1 ) / 2;
    }
    return \@costs;
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}


48 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 8 - Seven Segment Search

[ AoC problem link ] [ Discussion ].

Day 08 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/any all/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
use Algorithm::Combinatorics qw(permutations);
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
sub solve;
### CODE
my @permutations = permutations( [ 'a' .. 'g' ] );

my %patterns = (
    0 => [qw/0 1 2   4 5 6/],
    1 => [qw/    2     5  /],
    2 => [qw/0   2 3 4   6/],
    3 => [qw/0   2 3   5 6/],
    4 => [qw/  1 2 3   5  /],
    5 => [qw/0 1   3   5 6/],
    6 => [qw/0 1   3 4 5 6/],
    7 => [qw/0   2     5  /],
    9 => [qw/0 1 2 3   5 6/],
);

my $count = 0;
my @values;
my @output;
my $sum = 0;
for my $line (@input) {
    my ( $in, $out ) = split( /\|/, $line );
    @values = split( " ", $in );
    @output = split( " ", $out );
    for my $el (@output) {
        $count++
            if ( length($el) == 2
            or length($el) == 3
            or length($el) == 4
            or length($el) == 7 );
    }
    my $sol = solve(@values);
    if ( defined $sol ) {

        my $num = '';
        for my $o ( map { join( "", sort split( //, $_ ) ) } @output ) {
            $num .= $sol->{$o};
        }
        $sum += $num;
    }
}
### FINALIZE - tests and run time
is( $count, 470,    "Part 1: $count" );
is( $sum,   989396, "Part 2: $sum" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS

sub solve {

    # segment numbering:
    # +-0-+
    # 1   2
    # +-3-+
    # 4   5
    # +-6-+
    my $ret = undef;
    my @v   = @_;
    @v = sort { length($a) <=> length($b) }
        map { join( "", sort split( //, $_ ) ) } @v;

    for my $per (@permutations) {
        my %p;
	# check if the current permutation can lead to a solution
	# bail if doesn't
	
        # One, Four, Seven
        my $pattern = join( '', sort map { $per->[$_] } @{ $patterns{1} } );
        next unless $pattern eq $v[0];
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{7} } );
        next unless $pattern eq $v[1];
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{4} } );
        next unless $pattern eq $v[2];

        # Two Three Five
        my @ok = ( 0, 0, 0 );
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{2} } );
        $ok[0] = any { $pattern eq $v[$_] } qw/3 4 5/;
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{3} } );
        $ok[1] = any { $pattern eq $v[$_] } qw/3 4 5/;
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{5} } );
        $ok[2] = any { $pattern eq $v[$_] } qw/3 4 5/;
        next unless all { $_ == 1 } @ok;

        # Zero Six Nine
        @ok      = ( 0, 0, 0 );
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{0} } );
        $ok[0]   = any { $pattern eq $v[$_] } qw/6 7 8/;
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{6} } );
        $ok[1]   = any { $pattern eq $v[$_] } qw/6 7 8/;
        $pattern = join( '', sort map { $per->[$_] } @{ $patterns{9} } );
        $ok[2]   = any { $pattern eq $v[$_] } qw/6 7 8/;
        next unless all { $_ == 1 } @ok;

	# we've reached a solution, let's return a mapping of strings
	# to numbers
        $p{8} = $v[-1];

        $p{1} = $v[0];
        $p{7} = $v[1];
        $p{4} = $v[2];
	# we need to filter these to identify the unique ones 
        my @rest = @v[ 3, 4, 5, 6, 7, 8 ];
        while (@rest) {
            for my $i ( 2, 3, 5, 0, 6, 9 ) {
                if ( @rest
                    and
                    join( "", sort map { $per->[$_] } @{ $patterns{$i} } ) eq
                    $rest[0] )
                {
                    $p{$i} = shift @rest;
                }
            }
        }
        $ret = { reverse %p } if scalar keys %p == 10;
    }
    return $ret;
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

125 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 9 - Smoke Basin

[ AoC problem link ] [ Discussion ].

Day 09 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/all product/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $Map;
my $id = 0;
my $Basins;

# We use a hash-of-hashes construct for the map, because it makes
# checking the boundaries much easier

my $r = 1;
for my $line (@input) {
    my $c = 1;
    for ( split( //, $line ) ) {
        $Map->{$r}{$c} = { val => $_ };
        $c++;
    }
    $r++;
}

my $risk = 0;

# Part 1: search for low points and calculate the total risk level
for my $r ( keys %$Map ) {
    for my $c ( keys %{ $Map->{$r} } ) {
        my @neighbors;
        for my $d ( [ -1, 0 ], [ 1, 0 ], [ 0, -1 ], [ 0, 1 ] ) {
            my ( $dr, $dc ) = ( $r + $d->[0], $c + $d->[1] );
            if ( defined $Map->{$dr}{$dc} ) {
                push @neighbors, $Map->{$dr}{$dc}->{val};
            }
        }
        if ( all { $Map->{$r}{$c}->{val} < $_ } @neighbors ) {

            # we have a low point, give it an ID and add it to the
            # list of locations
            ++$id;
            $Basins->{$id} = { r => $r, c => $c };
            $Map->{$r}{$c}->{id} = $id;
            $risk += ( $Map->{$r}{$c}->{val} + 1 );
        }
    }
}

# starting at each low point, find the area that drains to it
for my $id ( keys %$Basins ) {

    # we use BFS
    my @queue = ( [ $Basins->{$id}{r}, $Basins->{$id}{c} ] );
    while (@queue) {
        my $cur = shift @queue;
        for my $d ( [ -1, 0 ], [ 1, 0 ], [ 0, -1 ], [ 0, 1 ] ) {
            my ( $dr, $dc ) = ( $cur->[0] + $d->[0], $cur->[1] + $d->[1] );

            if ( defined $Map->{$dr}{$dc} ) {

                # a point is in the basin if it is
                # - strictly higher than a neighbor
                # - not == 9
                # - not already marked as visited

                if ( $Map->{$dr}{$dc}{val}
                        > $Map->{ $cur->[0] }{ $cur->[1] }{val}
                    and $Map->{$dr}{$dc}{val} != 9
                    and !defined( $Map->{$dr}{$dc}{id} ) )
                {
                    $Map->{$dr}{$dc}{id} = $id;
                    push @queue, [ $dr, $dc ];
                }
            }
        }
    }
}
my %sizes;
for my $r ( keys %$Map ) {
    for my $c ( keys %{ $Map->{$r} } ) {
        if ( $Map->{$r}{$c}{id} ) {
            $sizes{ $Map->{$r}{$c}{id} }++;
        }
    }
}

# This horror is just to extract the values of the top basins by size
my $prod = product( map { $sizes{$_} }
        ( sort { $sizes{$b} <=> $sizes{$a} } keys %sizes )[ 0 .. 2 ] );
### FINALIZE - tests and run time
if ($testing) {
    is( $risk, 15,   "Part 1: $risk" );
    is( $prod, 1134, "Part 1: $prod" );
}
else {
    is( $risk, 423,     "Part 1: $risk" );
    is( $prod, 1198704, "Part 2: $prod" );
}

done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

96 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 10 - Syntax Scoring

[ AoC problem link ] [ Discussion ].

Day 10 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE

my %closers    = ( ']' => '[', ')' => '(', '}' => '{',  '>' => '<' );
my %openers = reverse %closers;
my %scores     = ( ')' => 3,   ']' => 57,  '}' => 1197, '>' => 25137 );
my %autoscores = ( ')' => 1,   ']' => 2,   '}' => 3,    '>' => 4 );
my @part2;
sub parse_line;
my $score = 0;

for my $line (@input) {
    my $ret = parse_line($line);
    if ( $ret !~ /1/ ) {
        $score += $scores{$ret};
    }
}

@part2 = sort { $a <=> $b } @part2;

my $part2 = $part2[ int( ( scalar @part2 ) / 2 ) ];
### FINALIZE - tests and run time
is( $score, 318081,     "Part 1: $score" );
is( $part2, 4361305341, "Part 2: $part2" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub parse_line {
    my ($l) = @_;
    my @l = split( '', $l );
    my @stack;
LOOP:
    for my $t (@l) {

        if ( exists $closers{$t} ) {    # found a closing token
            my $c = pop @stack;
            return $t unless ( $closers{$t} eq $c );
        }
        else {
            push @stack, $t;
        }
    }

    # part 2
    if ( scalar @stack > 1 ) { 
        my @autocomplete = map { $openers{$_} } reverse @stack;
        my $total        = 0;
        for my $c (@autocomplete) {
            $total *= 5;
            $total += $autoscores{$c};
        }
        push @part2, $total;
    }

    return 1;
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

64 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 11 - Dumbo Octopus

[ AoC problem link ] [ Discussion ].

Day 11 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum/;
use Data::Dump qw/dump/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $Map;
my %ans;
sub dump_map;
my $r = 0;
for my $line (@input) {
    my $c = 0;
    for my $v ( split( "", $line ) ) {
        $Map->{$r}{$c} = { v => $v, sweep => 0 };
        $c++;
    }
    $r++;
}

#dump_map;
my $step = 1;

my $flash_count = 0;
my $has_synced  = 0;
while ( !$has_synced ) {

    # initial step, raise all levels by one
    for my $r ( keys %$Map ) {
        for my $c ( keys %{ $Map->{$r} } ) {
            $Map->{$r}{$c}{v}++;
        }
    }

    # sweep until all changes have been effected
    my $has_changed = 1;
    my $sweep_count = 0;
    while ($has_changed) {
        my $changes = 0;
        for my $r ( keys %$Map ) {
            for my $c ( keys %{ $Map->{$r} } ) {

                # will a recent flash change this cell's level ?
                next if $Map->{$r}{$c}{v} > 9;
                for my $d (
			   [ -1, -1 ], [ -1, 0 ], [ -1, 1 ],
			   [  0, -1 ],            [  0, 1 ],
			   [  1, -1 ], [  1, 0 ], [  1, 1 ]
                    )
                {
                    my ( $dr, $dc ) = ( $r + $d->[0], $c + $d->[1] );

                    if (    defined $Map->{$dr}{$dc}
                        and $Map->{$dr}{$dc}{v} > 9
                        and $Map->{$dr}{$dc}{sweep} == $sweep_count )
                    {

                        $Map->{$r}{$c}{v}++;
                        $Map->{$r}{$c}{sweep} = $sweep_count + 1;
                        $changes++;
                    }
                }
            }
        }
        $sweep_count++;
        $has_changed = 0 if $changes == 0;
    }

    # reset values for next step, count flashes;
    my $step_flashes = 0;
    for my $r ( keys %$Map ) {
        for my $c ( keys %{ $Map->{$r} } ) {
            if ( $Map->{$r}{$c}{v} > 9 ) {
                $Map->{$r}{$c}{v} = 0;
                $step_flashes++;
            }
            $Map->{$r}{$c}{sweep} = 0;
        }
    }
    if ( $step_flashes == 100 ) {
        $has_synced = 1;
        $ans{2} = $step;
    }
    $flash_count += $step_flashes;
    $ans{1} = $flash_count if $step == 100;
    $step++;
}

### FINALIZE - tests and run time
if ($testing) {
    is( $ans{1}, 1656, "Part 1: " . $ans{1} );
    is( $ans{2},  195, "Part 2: " . $ans{2} );
}
else {
    is( $ans{1}, 1652, "Part 1: " . $ans{1} );
    is( $ans{2},  220, "Part 2: " . $ans{2} );
}

done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub dump_map {
    for my $r ( sort { $a <=> $b } keys %$Map ) {
        for my $c ( sort { $a <=> $b } keys %{ $Map->{$r} } ) {
            print $Map->{$r}{$c}{v};
        }
        print "\n";
    }
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

110 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 12 - Passage Pathing

[ AoC problem link ] [ Discussion ].

Day 12 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test3.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $Map;
for my $line (@input) {
    my ( $from, $to ) = $line =~ m/^(.*)-(.*)$/;

    $Map->{$from}{$to}++ unless ( $to eq 'start' or $from eq 'end' );
    $Map->{$to}{$from}++ unless ( $to eq 'end'   or $from eq 'start' );
}

# algo from /u/Abigail
# - https://abigail.github.io/HTML/AdventOfCode/2021/day-12.html
my @queue;
push @queue, [ 'start', {}, 0 ];
my ( $count1, $count2 ) = ( 0, 0 );
BFS:
while (@queue) {
    my ( $cur, $seen, $twice ) = @{ shift @queue };
    if ( $cur eq 'end' ) {

        $count1++ if !$twice;
        $count2++;
        next;
    }
    next if ( $seen->{$cur} and $cur eq lc($cur) and $twice++ );

    for my $k ( keys %{ $Map->{$cur} } ) {
        push @queue, [ $k, { %$seen, $cur => 1 }, $twice ];
    }

}
### FINALIZE - tests and run time
is( $count1,   5756, "Part 1: $count1" );
is( $count2, 144603, "Part 2: $count2" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

45 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 13 - Transparent Origami

[ AoC problem link ] [ Discussion ].

Day 13 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use List::Util qw/sum max/;
use Data::Dump qw/dump/;
use Clone qw/clone/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $Map;
my %ans;
my @instr;
sub dump_map;
sub dimensions;
for my $line (@input) {
    if ( $line =~ m/^(\d+),(\d+)$/ ) {
        $Map->{$1}{$2}++;
    }
    elsif ( $line =~ m/^fold along (.)=(\d+)$/ ) {
        push @instr, [ $1, $2 ];
    }
}
my $fold = 1;
for my $cmd (@instr) {

    my $half1;
    my $half2;
    for my $x ( keys %$Map ) {
        for my $y ( keys %{ $Map->{$x} } ) {
            if ( $cmd->[0] eq 'x' ) {
                if ( $x > $cmd->[1] ) {
                    $half2->{ $cmd->[1] - ( $x - $cmd->[1] ) }{$y}++;
                }
                else {
                    $half1->{$x}{$y}++;
                }
            }
            elsif ( $cmd->[0] eq 'y' ) {
                if ( $y > $cmd->[1] ) {
                    $half2->{$x}{ $cmd->[1] - ( $y - $cmd->[1] ) }++;
                }
                else {
                    $half1->{$x}{$y}++;
                }
            }
        }
    }

    $Map = clone $half1;

    for my $x ( keys %$half2 ) {
        for my $y ( keys %{ $half2->{$x} } ) {
            $Map->{$x}{$y}++;
        }
    }
    # part 1
    if ($fold == 1) {
	$ans{1}=0;
	for my $x ( keys %$Map ) {
	    for my $y ( keys %{ $Map->{$x} } ) {
		$ans{1}++ if $Map->{$x}{$y};
	    }
	}

    }
    $fold++;
}


my $digest = dump_map;

### FINALIZE - tests and run time
is($ans{1}, 753, "Part 1: ".$ans{1});
is( $digest, 1536, "Part 2 OK");

done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub dump_map {
    my $output;
    my $digest;
    my $max_y = 0;
    for my $x ( keys %$Map ) {
        $max_y
            = max( keys %{ $Map->{$x} } ) > $max_y
            ? max( keys %{ $Map->{$x} } )
            : $max_y;
    }
    my @rows;
    for my $r ( sort { $a <=> $b } keys %$Map ) {
	my $digits;
        for my $c ( 0 .. $max_y ) {
            $output->[$c][$r] = $Map->{$r}{$c} ? '█' : '.';
	    $digits .= $Map->{$r}{$c}?0:1;
        }
	$digest += ord( '0b'.$digits);
    }
    for my $r (0..(scalar @$output)-1) {
        say join( '', map { $_ ? $_ : '|' } @{$output->[$r]} );
    }
    return $digest;
}


105 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 14 - Extended Polymerization

[ AoC problem link ] [ Discussion ].

Day 14 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $template = shift @input;
shift @input;
my %rules;
my @ans;
for my $line (@input) {
    if ( $line =~ m/(.*) -> (.*)/ ) {
        $rules{$1} = $2;
    }
}
my $step       = 1;
my @initial    = split( "", $template );
# we save this because it will be included in every subsequent string 
my $first_elem = $initial[0];

my %pairs;
for my $idx ( 0 .. $#initial - 1 ) {
    $pairs{ $initial[$idx] . $initial[ $idx + 1 ] }++;
}
my $end = $initial[-1];

my $LIMIT = 40;
while ( $step <= $LIMIT ) {

    # count elements and add
    my %elements;
    $elements{$first_elem} = 1;

    my %next;

    for my $k ( keys %pairs ) {
        if ( $rules{$k} ) {
            my @in = split( '', $k );
	    # add new combinations to following sequence
            $next{ $in[0] . $rules{$k} } += $pairs{$k};
            $next{ $rules{$k} . $in[1] } += $pairs{$k};

	    # add up the elements, only newly added middle and right -
	    # the left element is already counted in the previous pair
	    
            $elements{ $rules{$k} } += $pairs{$k};
            $elements{ $in[1] } += $pairs{$k};
        }
    }
    # output all the big numbers 
    my @freq = sort { $elements{$b} <=> $elements{$a} } keys %elements;
    printf(
        "%2d %14d %14d %14d\n",
        (   $step,
            $elements{ $freq[0] },
            $elements{ $freq[-1] },
            $elements{ $freq[0] } - $elements{ $freq[-1] }
        )
    );
    if ( $step == 10 or $step == 40 ) {
        push @ans, $elements{ $freq[0] } - $elements{ $freq[-1] };
    }
    %pairs = %next;
    $step++;
}

### FINALIZE - tests and run time

if ($testing) {
    is( $ans[0],          1588, "Part 1: " . $ans[0] );
    is( $ans[1], 2188189693529, "Part 2: " . $ans[1] );
}
else {
    is( $ans[0],          2321, "Part 1: " . $ans[0] );
    is( $ans[1], 2399822193707, "Part 2: " . $ans[1] );
}

done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

80 lines [ Plain text ] [ ^Top ]

Day 14 - part 1


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $template = shift @input;
shift @input;
my %rules;
for my $line (@input) {
    if ( $line =~ m/(.*) -> (.*)/ ) {
        $rules{$1} = $2;
    }
}
my $step    = 1;
my @initial = split( "", $template );
my $LIMIT   = 10;
while ( $step <= $LIMIT ) {
    my @next;
    my $idx = 0;
    while ( $idx < $#initial ) {
        my $pair = $initial[$idx] . $initial[ $idx + 1 ];

        if ( $rules{$pair} ) {
            push @next, ( $initial[$idx], $rules{$pair} );
            $idx += 1;
        }
        else {
            $idx++;
        }
    }
    push @next, $initial[-1];
    @initial = @next;

    $step++;
}
my %freq;
for my $c (@initial) {
    $freq{$c}++;
}
my @res = ( sort { $freq{$b} <=> $freq{$a} } keys %freq );
my ( $most, $least ) = ( $freq{ $res[0] }, $freq{ $res[-1] } );
my $ans1 = $most - $least;

### FINALIZE - tests and run time
is( $ans1, 2321, "Part 1: $ans1" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

57 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 15 - Chiton

[ AoC problem link ] [ Discussion ].

Day 15 - part 2


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum max/;
use Data::Dump qw/dump/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
use Array::Heap::PriorityQueue::Numeric;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $Map;
my %ans;
sub dump_map;
my $r     = 0;
my $max_c = 0;
for my $line (@input) {
    my $c = 0;
    for my $n ( split( '', $line ) ) {
        $Map->{$r}{$c} = $n;
        $c++;
    }
    $max_c = $c;
    $r++;
}
my $max_r = max( keys %$Map ) + 1;

# build bigger map for part 2
# extend down
for my $r ( $max_r .. 5 * $max_r - 1 ) {
    for my $c ( 0 .. $max_c - 1 ) {
        my $new_val = $Map->{ $r - $max_r }{$c} + 1;
        $new_val = 1 if $new_val > 9;
        $Map->{$r}{$c} = $new_val;
    }
}

# extend to the right
for my $r ( sort { $a <=> $b } keys %$Map ) {
    for my $c ( $max_c .. 5 * $max_c - 1 ) {
        my $new_val = $Map->{$r}{ $c - $max_c } + 1;
        $new_val = 1 if $new_val > 9;
        $Map->{$r}{$c} = $new_val;
    }
}

my $goal = $testing ? [ 49, 49 ] : [ 499, 499 ];
my $pq   = Array::Heap::PriorityQueue::Numeric->new();
$pq->add( [ 0, 0 ], 0 );
my $came_from;
my $cost_so_far;
$cost_so_far->{0}{0} = 0;
SEARCH:

while ( $pq->peek ) {
    my $cur = $pq->get();
    if ( $cur->[0] == $goal->[0] and $cur->[1] == $goal->[1] ) {
        $ans{2} = $cost_so_far->{ $goal->[0] }{ $goal->[1] };
        last SEARCH;
    }

    # try to move
    for my $d ( [ -1, 0 ], [ 0, -1 ], [ 1, 0 ], [ 0, 1 ] ) {
        my $dr = $cur->[0] + $d->[0];
        my $dc = $cur->[1] + $d->[1];
        next unless exists $Map->{$dr}{$dc};

        my $new_cost
            = $cost_so_far->{ $cur->[0] }{ $cur->[1] } + $Map->{$dr}{$dc};

        if ( !exists $cost_so_far->{$dr}{$dc}
            or $new_cost < $cost_so_far->{$dr}{$dc} )
        {
            $cost_so_far->{$dr}{$dc} = $new_cost;
            $pq->add( [ $dr, $dc ], $new_cost );
        }
    }
}

### FINALIZE - tests and run time
is( $ans{2}, 2800, "Part 2: " . $ans{2} );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub dump_map {
    for my $r ( sort { $a <=> $b } keys %$Map ) {
        for my $c ( sort { $a <=> $b } keys %{ $Map->{$r} } ) {
            print $Map->{$r}{$c};
        }
        print "\n";
    }
}

90 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 16 - Packet Decoder

[ AoC problem link ] [ Discussion ].

Day 16 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum min max product all/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;
no warnings 'portable';
my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

sub decode;

my %actions = (
    4 => 'literal number',
    0 => sub { sum @_ },
    1 => sub { product @_ },
    2 => sub { min @_ },
    3 => sub { max @_ },
    5 => sub { $_[0] > $_[1] ? 1 : 0 },
    6 => sub { $_[0] < $_[1] ? 1 : 0 },
    7 => sub { $_[0] == $_[1] ? 1 : 0 },

);

my @test_p1 = (
    'D2FE28',                     '38006F45291200',
    'EE00D40C823060',             '8A004A801A8002F478',
    '620080001611562C8802118E34', 'C0015000016115A2E0802F182340',
    'A0016C880162017C3686B18A3D4780',
);
my @ans_p1 = ( 6, 9, 14, 16, 12, 23, 31 );
my @test_p2
    = qw/C200B40A82 04005AC33890 880086C3E88112 CE00C43D881120 D8005AC2A8F0 F600BC2D8F 9C005AC2F8F0 9C0141080250320F1802104A08/;
my @ans_p2 = qw/3 54 7 9 1 0 0 1/;
### CODE
my $version_sum;
my $idx = 0;
say "==> Part 1 <==";
for my $line ( @test_p1, $input[0] ) {
    chomp $line;
    $version_sum = 0;
    my $B;
    for ( split( '', $line ) ) {
        push @$B, split( '', sprintf( "%04b", hex($_) ) );
    }

    my @res;
    push( @res, decode($B) );
    if ( $idx < scalar @ans_p1 ) {
        is( $version_sum, $ans_p1[$idx], "Test $idx: ok" );
    }
    else {
        is( $version_sum, 866, "Part 1: $version_sum" );
    }
    $idx++;
}
say "==> Part 2 <==";
$idx = 0;
for my $line ( @test_p2, $input[0] ) {
    chomp $line;
    $version_sum = 0;
    my $B;
    for ( split( '', $line ) ) {
        push @$B, split( '', sprintf( "%04b", hex($_) ) );
    }

    my @res;
    decode( $B, 0, \@res );

    if ( $idx < scalar @ans_p2 ) {
        is( $res[0], $ans_p2[$idx], "Test $idx: ok" );
    }
    else {
        is( $res[0], 1392637195518, "Part 2: $res[0]" );
    }
    $idx++;
}

### FINALIZE - tests and run time

done_testing();
say sec_to_hms( tv_interval($start_time) );
### SUBS
sub decode {
    my ( $in, $reps, $vals ) = @_;
    my $visits = 0;
    while (@$in) {
        last if all { $_ == 0 } @$in;
        last if $reps and $reps == $visits;

        my $version = oct( '0b' . join( '', splice( @$in, 0, 3 ) ) );
        $version_sum += $version;
        my $id = oct( '0b' . join( '', splice( @$in, 0, 3 ) ) );
        $visits++;
        if ( $id == 4 ) {

            # literal number
            my $next = 1;
            my @num;
            while ($next) {
                my @chunk = splice( @$in, 0, 5 );
                $next = shift @chunk;
                push @num, @chunk;
            }
            push @$vals, oct( '0b' . join( '', @num ) );
        }
        else {
            my @subvals;
            my $lenid = shift @$in;
            if ($lenid) {    # 11
                my $n = oct( '0b' . join( '', splice( @$in, 0, 11 ) ) );
                decode( $in, $n, \@subvals );
            }
            else {           # 15
                my $len = oct( '0b' . join( '', splice( @$in, 0, 15 ) ) );
                my $sub = [ splice( @$in, 0, $len ) ];
                decode( $sub, 0, \@subvals );

            }
            push @$vals, $actions{$id}->(@subvals);
        }
    }
    return $in;
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

121 lines [ Plain text ] [ ^Top ]

Day 16 - part 1


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum min max product/;
use Data::Dump qw/dump/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;
no warnings 'portable';
my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

sub decode;

my @test_p1 = (
    'D2FE28',                     '38006F45291200',
    'EE00D40C823060',             '8A004A801A8002F478',
    '620080001611562C8802118E34', 'C0015000016115A2E0802F182340',
    'A0016C880162017C3686B18A3D4780',
);
my @ans_p1 = ( 6, 9, 14, 16, 12, 23, 31 );
### CODE
my $version_sum;
my $idx = 0;

for my $line ( @test_p1, $input[0] ) {
    chomp $line;
    say $line if $debug;
    $version_sum = 0;
    my $B;
    for ( split( '', $line ) ) {
        push @$B, split( '', sprintf( "%04b", hex($_) ) );
    }

    my @res;
    push( @res, decode($B) );
    if ( $idx < scalar @ans_p1 ) {
        is( $version_sum, $ans_p1[$idx], "Test $ans_p1[$idx]: ok" );
    }
    else {
        is( $version_sum, 866, "Part 1: $version_sum" );
    }
    $idx++;
}

### FINALIZE - tests and run time
# is();
done_testing();
say sec_to_hms( tv_interval($start_time) );
### SUBS
sub decode {
    my ($in) = @_;
    my $res;

    while (@$in) {

        my $version = oct( '0b' . join( '', splice( @$in, 0, 3 ) ) );
        $version_sum += $version;
        my $id = oct( '0b' . join( '', splice( @$in, 0, 3 ) ) );
        say "(V: $version I: $id)" if $debug;
        if ( $id == 4 ) {

            # literal number
            my $next = 1;
            my @num;
            while ($next) {
                my @chunk = splice( @$in, 0, 5 );
                $next = shift @chunk;
                push @num, @chunk;
            }
            $res = oct( '0b' . join( '', @num ) );
            say "(Num: $res)" if $debug;
        }
        else {
            my @vals;
            my $lenid = shift @$in;
            if ($lenid) {    # 11
                my $n = oct( '0b' . join( '', splice( @$in, 0, 11 ) ) );
                say "(Rep: $n)" if $debug;
                for ( 1 .. $n ) {
                    push @vals, decode($in);
                }
            }
            else {           # 15
                my $len = oct( '0b' . join( '', splice( @$in, 0, 15 ) ) );
                say "(L: $len)" if $debug;
                my $sub = [ splice( @$in, 0, $len ) ];
                say "  ", join( '', @$sub ) if $debug;
                push @vals, decode($sub);

            }

        }

    }

    return $res;
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}


94 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 17 - Trick Shot

[ AoC problem link ] [ Discussion ].

Day 17 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my %ans;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $target;
if ( $input[0] =~ m/x=(\d+)..(\d+), y=-(\d+)..-(\d+)/ ) {
    $target = {
        x => { min => $1, max => $2 },
        y => { min => $3 * (-1), max => $4 * (-1) }
    };
}

# part 1: only need to consider y. Each y(t) is a triangular number,
# so y(t) = t*(t+1)/2. If we launch upwards we will have v=0 at the
# apex. The next y's after that will have to cross the x-axis and hit
# the target box. So the highest point will be y_min*(y_min+1)/2

$ans{1} = $target->{y}{min} * ( $target->{y}{min} + 1 ) / 2;

# part 2: just brute force the solution space
my @hits;
my $count = 0;
for my $vx ( 0 .. $target->{x}{max} )
{    # any faster and we overshoot at step 1
    for my $vy ( $target->{y}{min} .. 105 )
    {    # upper range found by inspection

        my $v = { x => $vx, y => $vy };
        if ( hit($v) ) {
            push @hits, $v;
        }
    }
}

$ans{2} = scalar @hits;
is( $ans{1}, 5565, "Part 1: " . $ans{1} );
is( $ans{2}, 2118, "Part 2: " . $ans{2} );
### FINALIZE - tests and run time
# is();
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS

sub hit {

    my ($v) = @_;
    my ( $x, $y ) = ( 0, 0 );
    my $hit   = 0;
    my $max_y = $target->{y}{min};
    while ( $y > $target->{y}{min} and $x <= $target->{x}{max} ) {
        $x = $x + $v->{x};
        $y = $y + $v->{y};

        if (    $x >= $target->{x}{min}
            and $x <= $target->{x}{max}
            and $y <= $target->{y}{max}
            and $y >= $target->{y}{min} )
        {
            $hit = 1;
            last;
        }

        if ( $v->{x} > 0 ) {
            $v->{x}--;
        }
        elsif ( $v->{x} < 0 ) {
            $v->{x}++;
        }
        $v->{y}--;
    }
    if ($hit) {
        return $v;
    }
    else {
        return undef;
    }
}

sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

76 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 18 - Snailfish

[ AoC problem link ] [ Discussion ].

Day 18 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum any all/;
use Data::Dump qw/dump/;
use POSIX qw [ceil floor];

use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
### CODE
sub explode;
sub mysplit;
sub reduce;
sub add;
sub dump_snf;
sub magnitude;

my @homework;
my %ans;

for my $line (@input) {
    push @homework, [ split( '', $line ) ];
}

# part 1
my $t1 = $homework[0];
my $sum;
for my $idx ( 1 .. $#homework ) {
    my $t2 = $homework[$idx];
    $sum = add( $t1, $t2 );
    $t1  = $sum;
}
$ans{1} = magnitude($sum);
is( $ans{1}, 4417, "Part 1: $ans{1}" );

# part 2
my $max_mag = 0;
for my $i ( keys @homework ) {
    say "==> $i" if $i%10==0;
    for my $j ( keys @homework ) {
        next if $i == $j;
        my ( $mag1, $mag2 ) = (
            magnitude( add( $homework[$i], $homework[$j] ) ),
            magnitude( add( $homework[$i], $homework[$j] ) )
        );
        $max_mag = $mag1 if $mag1 > $max_mag;
        $max_mag = $mag2 if $mag2 > $max_mag;
    }
}

$ans{2} = $max_mag;
is( $ans{2}, 4796, "Part 2: $ans{2}" );
### FINALIZE - tests and run time

done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

sub explode {
    my ($snf) = @_;

    my $depth = 0;
    for my $idx ( keys @$snf ) {

        my $part = $snf->[$idx];
        if ( $part eq '[' ) {
            $depth++;
            next;
        }
        if ( $part eq ']' ) {
            $depth--;
            next;
        }
        next if $part eq ',';
        if ( $depth > 4 ) {

            my $left  = $part;
            my $i     = $idx;
            my $right = $snf->[ $i + 2 ];
            my $j     = $i;
            next unless all { $_ =~ /\d+/ } ( $left, $right );
            say join( '', @{$snf}[ $i - 1 .. $i + 3 ] ) if $debug;
            while ( --$j >= 0 ) {
                next if ( any { $snf->[$j] eq $_ } ( '[', ',', ']' ) );
                $snf->[$j] += $left;
                last;
            }
            my $k = $i + 2;
            while ( ++$k < @$snf ) {
                next if ( any { $snf->[$k] eq $_ } ( '[', ',', ']' ) );
                $snf->[$k] += $right;
                last;
            }
            splice @$snf, $i - 1, 5, 0;
            return $snf;
        }

    }
    return undef;
}

sub mysplit {
    my ($snf) = @_;
    for my $idx ( keys @$snf ) {
        my $part = $snf->[$idx];
        next
            if ( any { $snf->[$idx] eq $_ } ( '[', ',', ']' ) or $part < 10 );
        splice @$snf, $idx, 1,
            (
            '[', floor( $snf->[$idx] / 2 ),
            ',', ceil( $snf->[$idx] / 2 ), ']'
            );
        return $snf;
    }
    return undef;
}

sub reduce {
    my ($snf) = @_;
    my @stack;
    push @stack, 'spl';
    push @stack, 'exp';
    while (@stack) {
        my $act = pop @stack;
        my $res;
        if ( $act eq 'exp' ) {
            say "=> explode" if $debug;
            $res = explode($snf);
            if ($res) {
                $snf = $res;
                push @stack, 'exp';
            }
            dump_snf($snf) if $debug;
        }
        elsif ( $act eq 'spl' ) {
            say "==> split" if $debug;
            $res = mysplit($snf);
            if ($res) {
                $snf = $res;
                push @stack, 'spl';
                push @stack, 'exp';
            }
            dump_snf($snf) if $debug;

        }
    }
    return $snf;
}

sub add {    # input: two snailfish numbers
    my ( $t1, $t2 ) = @_;
    my $snf = [ '[', @$t1, ',', @$t2, ']' ];
    dump_snf($snf) if $debug;
    my $res = reduce($snf);
    return $res;
}

sub dump_snf {
    my ($snf) = @_;
    my @arr;
    my $depth = 0;
    for my $idx ( keys @$snf ) {
        my $part = $snf->[$idx];
        print $part;
        if ( $part eq '[' ) {
            $depth++;
            $arr[$idx] = $depth;
            next;
        }
        if ( $part eq ']' ) {
            $depth--;
            $arr[$idx] = $depth;
            next;
        }
    }
    print "\n";
    for my $idx ( keys @$snf ) {
        print $arr[$idx] ? $arr[$idx] : '.';
    }

    print "\n";
}

sub magnitude {
    no warnings 'uninitialized';

    my ($snf) = @_;
    while ( scalar @$snf > 2 ) {
        for my $idx ( keys @$snf ) {
            if (    $snf->[$idx] eq '['
                and $snf->[ $idx + 1 ] =~ /\d+/
                and $snf->[ $idx + 2 ] eq ','
                and $snf->[ $idx + 3 ] =~ /\d+/
                and $snf->[ $idx + 4 ] eq ']' )
            {
                my $mag = 3 * $snf->[ $idx + 1 ] + 2 * $snf->[ $idx + 3 ];
                splice @$snf, $idx, 5, $mag;
            }
        }
    }
    return $snf->[0];
}

189 lines [ Plain text ] [ ^Top ]

Day 18 - testing


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use List::Util qw/sum any all/;
use Data::Dump qw/dump/;
use POSIX qw [ceil floor];

use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 1;
my $debug = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
### CODE
sub explode;
sub mysplit;
sub reduce;
sub add;
sub dump_snf;
sub magnitude;
# insert test cases here 
my @test_explode = ('[[[[[9,8],1],2],3],4]',
		    '[7,[6,[5,[4,[3,2]]]]]',
		    '[[6,[5,[4,[3,2]]]],1]',
		    '[[3,[2,[1,[7,3]]]],[6,[5,[4,[3,2]]]]]',
		    '[[3,[2,[8,0]]],[9,[5,[4,[3,2]]]]]');
my @ans_explode = ('[[[[0,9],2],3],4]',
		   '[7,[6,[5,[7,0]]]]',
		   '[[6,[5,[7,0]]],3]',
		   '[[3,[2,[8,0]]],[9,[5,[4,[3,2]]]]]',
		   '[[3,[2,[8,0]]],[9,[5,[7,0]]]]' );
for my $idx (keys @test_explode) {
    my $str = $test_explode[$idx];
    my $res = explode( [split('', $str)]);
    is( join('',@$res), $ans_explode[$idx], "explode ok");
}
my $str ='[[[[[4,3],4],4],[7,[[8,4],9]]],[1,1]]';
my $snf = [split('', $str)];
my $res = reduce($snf);
is(join('',@$res),'[[[[0,7],4],[[7,8],[6,0]]],[8,1]]', "sum 1 ok");
my @arr = ('[[[[4,3],4],4],[7,[[8,4],9]]]','[1,1]');
$res = add( $arr[0], $arr[1]);
is(join('',@$res),'[[[[0,7],4],[[7,8],[6,0]]],[8,1]]', "sum 2 ok");
my @sum_ans = ('[[[[1,1],[2,2]],[3,3]],[4,4]]','[[[[3,0],[5,3]],[4,4]],[5,5]]','[[[[5,0],[7,4]],[5,5]],[6,6]]');
for my $end (4..6) {
    my @list;
    for my $i (1..$end) {
	push @list, "[$i,$i]";
    }
    my $t1 = shift @list;
    my $res;
    while (@list) {
	my $t2 = shift @list;
	$res = add( $t1, $t2);
	$t1 = join('',@$res);
    }
    is( $t1, $sum_ans[$end-4], "add example  ok");
}
my @long;
while () {
    chomp;
    push @long, $_;
}
my $t1 = shift @long;
$res = undef;
while (@long) {
    my $t2 = shift @long;
    $res = add( $t1, $t2 );
    $t1 = join('',@$res);
}
is(join('',@$res), '[[[[8,7],[7,7]],[[8,6],[7,7]]],[[[0,7],[6,6]],[8,7]]]', "long example ok");

my %mag_tests =('[[1,2],[[3,4],5]]' => 143,
'[[[[0,7],4],[[7,8],[6,0]]],[8,1]]' => 1384,
'[[[[1,1],[2,2]],[3,3]],[4,4]]' => 445,
'[[[[3,0],[5,3]],[4,4]],[5,5]]' => 791,
'[[[[5,0],[7,4]],[5,5]],[6,6]]' => 1137,
'[[[[8,7],[7,7]],[[8,6],[7,7]]],[[[0,7],[6,6]],[8,7]]]' => 3488);

for my $m (sort keys %mag_tests) {
    my $snf = [split('',$m)];
    my $res = magnitude( $snf);
    is( $res, $mag_tests{$m}, "magnitude $mag_tests{$m}");

}
$t1 = shift @input;
$res = undef;
while (@input) {
    my $t2 = shift @input;
    $res = add( $t1, $t2 );
    $t1 = join('', @$res);
}
### FINALIZE - tests and run time
is(magnitude( $res ),4140 ,"final test");

done_testing();
say sec_to_hms(tv_interval($start_time));

### SUBS
sub sec_to_hms {  
    my ($s) = @_;
    return sprintf("Duration: %02dh%02dm%02ds (%.3f ms)",
    int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

sub explode {
    my ( $snf ) = @_;

    my $depth= 0;
    for my $idx (keys @$snf) {

	my $part = $snf->[$idx];
	if ($part eq '[' ) {
	    $depth++;
	    next;
	}
	if ($part eq ']') {
	    $depth--;
	    next;
	}
	next if $part eq ',';
	if ($depth>4) {

	    my $left = $part;
	    my $i= $idx;
	    my $right = $snf->[$i+2];
	    my $j = $i;
	    next unless all { $_ =~ /\d+/} ($left, $right);
	    say join('', @{$snf}[$i-1..$i+3]) if $debug;
	    while (--$j >= 0) {
		next if ( any {$snf->[$j] eq $_} ('[',',',']'));
		$snf->[$j] += $left;
		last;
	    }
	    my $k = $i+2;
	    while (++$k < @$snf) {
		next if (any {$snf->[$k] eq $_} ('[',',',']'));
		$snf->[$k] += $right;
		last;
	    }
	    splice @$snf, $i-1,5, 0;
	    return $snf;
	}
	
    }
    return undef;
}

sub mysplit {
    my ( $snf ) = @_;
    for my $idx (keys @$snf) {
	my $part = $snf->[$idx];
	next if (any {$snf->[$idx] eq $_} ('[',',',']') or $part < 10);
	splice @$snf, $idx, 1,('[',floor( $snf->[$idx]/2),',',ceil($snf->[$idx]/2), ']');
	return $snf;
    }
    return undef;
}
sub reduce {
    my ( $snf ) = @_;
    my @stack;
    push @stack, 'spl';
    push @stack, 'exp';
    while (@stack) {
	my $act = pop @stack;
	my $res;
	if ($act eq 'exp') {
	    say "=> explode" if $debug;
	    $res = explode( $snf );
	    if ($res) {
		$snf=$res;

		push @stack, 'exp';
	    }
	    dump_snf( $snf ) if $debug;
	} elsif ($act eq 'spl') {
	    say "==> split" if  $debug;
	    $res = mysplit( $snf );
	    if ($res) {
		$snf=$res;
		push @stack, 'spl';
		push @stack, 'exp';
	    }
	    		dump_snf($snf) if $debug;

	}
    }
    return $snf;
}
sub add { # input: two strings representing snailfish numbers
    my ( $t1, $t2 ) = @_;
    my $snf = [split('','['.$t1.','.$t2.']')];
    dump_snf($snf) if $debug;
    my $res = reduce( $snf);
    return $res;
}

sub dump_snf {
    my ( $snf ) = @_;
    my @arr;
    my $depth =0;
    for my $idx (keys @$snf) {
	my $part = $snf->[$idx];
	print $part;
	if ($part eq '[') {
	    $depth++;
	    $arr[$idx]=$depth;
	    next;
	}
	if ($part eq ']') {
	    $depth--;
	    $arr[$idx]=$depth;
	    next;
	}
    }
    print "\n";
    for my $idx (keys @$snf) {
	print $arr[$idx]?$arr[$idx]:'.';
    }

    print "\n";
}

sub magnitude {
    no warnings 'uninitialized';

    my ( $snf ) = @_;
    while (scalar @$snf >2) {
	for my $idx (keys @$snf) {
	    if ($snf->[$idx] eq '[' and $snf->[$idx+1] =~ /\d+/ and $snf->[$idx+2] eq ',' and $snf->[$idx+3] =~ /\d+/ and $snf->[$idx+4] eq ']') {
		my $mag = 3 * $snf->[$idx+1] + 2 * $snf->[$idx+3];
		splice @$snf, $idx, 5, $mag;
	    }
	}
    }
    return $snf->[0];
}

__DATA__
[[[0,[4,5]],[0,0]],[[[4,5],[2,6]],[9,5]]]
[7,[[[3,7],[4,3]],[[6,3],[8,8]]]]
[[2,[[0,8],[3,4]]],[[[6,7],1],[7,[1,6]]]]
[[[[2,4],7],[6,[0,5]]],[[[6,8],[2,8]],[[2,1],[4,5]]]]
[7,[5,[[3,8],[1,4]]]]
[[2,[2,2]],[8,[8,1]]]
[2,9]
[1,[[[9,3],9],[[9,0],[0,7]]]]
[[[5,[7,4]],7],1]
[[[[4,2],2],6],[8,7]]

228 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 19 - Beacon Scanner

[ AoC problem link ] [ Discussion ].

Day 19 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum/;
use Data::Dump qw/dump/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

my %data;
my $scanner_id = undef;
for my $line (@input) {
    if ( $line =~ m/^--- scanner (\d+) ---$/ ) {
        $scanner_id = $1;
    }
    else {
        my $coord = [ split( /,/, $line ) ];
        push @{ $data{$scanner_id} }, $coord
            if defined $scanner_id and scalar @$coord;
    }
}

# load all tranformation matrices (copied from this site:
# https://www.euclideanspace.com/maths/algebra/matrix/transforms/examples/index.htm)
my $transforms;
my @list;
while () {
    chomp;
    s/\r//gm;
    push @list, $_;
}
while (@list) {

    # grab 3 lines + empty
    my $m;
    for ( 1 .. 3 ) {
        push @$m, [ split( /\s+/, shift @list ) ];
    }
    push @$transforms, $m;
    shift @list;
}
my $seen;
my @check = ( { id => 0, beacons => $data{0}, pos => "0,0,0" } );
my @res;
while (@check) {

    # this rigmarole is to avoid modifying datastructures in the loop
    my $next    = shift @check;
    my $s1      = $next->{id};
    my $beacons = $next->{beacons};
    push @res, $next;
    for my $s2 ( sort { $a <=> $b } keys %data ) {
        next if $s1 == $s2;
        if ( $seen->{$s1}{$s2} or $seen->{$s2}{$s1} ) {
            say "$s1 and $s2 have been compared, skipping" if $debug;
            next;
        }
        $seen->{$s1}{$s2}++;
        $seen->{$s2}{$s1}++;

        say "comp $s1 $s2";

        # generate all 24 possible rotations for each vector
        my $rotations;
        for my $v ( @{ $data{$s2} } ) {
            push @$rotations, rotate_vec($v);
        }

        my $matches;

        # compare each rotation to the vector in the "known" set,
        # taking differences for each axis

        for my $R (@$rotations) {
            my $rot = 0;
            for my $c (@$R) {
                for my $v (@$beacons) {
                    $matches->{$rot}{x}{ $v->[0] - $c->[0] }++;
                    $matches->{$rot}{y}{ $v->[1] - $c->[1] }++;
                    $matches->{$rot}{z}{ $v->[2] - $c->[2] }++;
                }
                $rot++;
            }
        }

        # if there is an overlap, there should be a "spike" of
        # matching differences, and the rotation that has these
        # differences in all three axes is the one we want. The
        # differences are the x,y,z offsets for the scanner

        my $summary;
        for my $rot ( sort { $a <=> $b } keys %{$matches} ) {
            for my $axis (qw/x y z/) {
                for my $d ( keys %{ $matches->{$rot}{$axis} } ) {

                    $summary->{$rot}{$axis} = $d
                        if $matches->{$rot}{$axis}{$d} >= 12;
                }
            }
        }

        #        dump $summary if $debug;

        my ($sought) = grep {
                    $summary->{$_}{x}
                and $summary->{$_}{y}
                and $summary->{$_}{z}
        } keys %$summary;
        if ( !$sought ) {
            say "no match, skipping to next" if $debug;
            next;
        }

        say "$s2 <-> $s1: $sought" if $debug;

        # transform the coordinates in the current set to the correct
        # offset and orientation, and push it to the array of
        # corrected sets to compare to others

        my $rotated;
        for my $v (@$rotations) {
            push @$rotated,
                [
                $v->[$sought][0] + $summary->{$sought}{x},
                $v->[$sought][1] + $summary->{$sought}{y},
                $v->[$sought][2] + $summary->{$sought}{z}
                ];
        }
        my $scanner_pos
            = join( ',', map { $summary->{$sought}{$_} } qw/x y z/ );
        push @check, { id => $s2, beacons => $rotated, pos => $scanner_pos };

    }
}

# gather all corrected beacons and count them
my %all_beacons;
for my $sc (@res) {

    for my $v ( @{ $sc->{beacons} } ) {
        my $str = join( ',', @$v );

        $all_beacons{$str}++;

    }
}

# calculate Manhattan distance between scanners
my $max_dist = 0;
sub manhattan;
for my $set1 (@res) {
    for my $set2 (@res) {
        next if $set1->{id} == $set2->{id};
        my $d = manhattan( $set1->{pos}, $set2->{pos} );
        $max_dist = $d if $d > $max_dist;
    }
}

### FINALIZE - tests and run time
is( scalar keys %all_beacons, 315,   "Part 1: " . scalar keys %all_beacons );
is( $max_dist,                13192, "Part 2: $max_dist" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

sub rotate_vec {    # given a 3 element arrayref, return all 24 rotations
    my ($v) = @_;
    my $res;
    for my $m (@$transforms) {
        push @$res,
            [
            $m->[0][0] * $v->[0] + $m->[0][1] * $v->[1] + $m->[0][2] * $v->[2],
            $m->[1][0] * $v->[0] + $m->[1][1] * $v->[1] + $m->[1][2] * $v->[2],
            $m->[2][0] * $v->[0] + $m->[2][1] * $v->[1] + $m->[2][2] * $v->[2]
            ];
    }
    return $res;
}

sub manhattan {
    my ( $p1, $p2 ) = @_;
    my @p1 = split( ',', $p1 );
    my @p2 = split( ',', $p2 );
    return sum( map { abs( $p2[$_] - $p1[$_] ) } ( 0 .. 2 ) );
}

__DATA__
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

0	-1	0
1	0	0
0	0	1

0	0	1
1	0	0
0	1	0

0	1	0
1	0	0
0	0	-1

0	0	-1
1	0	0
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

-1	0	0
0	0	1
0	1	0

0	1	0
-1	0	0
0	0	1

0	0	1
-1	0	0
0	-1	0

0	-1	0
-1	0	0
0	0	-1

0	0	-1
-1	0	0
0	1	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
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
-1	0	0


237 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 20 - Trench Map

[ AoC problem link ] [ Discussion ].

Day 20 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use List::Util qw/sum min max/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my %ans;
my @rule = split( '', $input[0] );
my $Map;

sub count_map;
for my $r ( 2 .. $#input ) {
    my $c = 0;
    for my $p ( split( '', $input[$r] ) ) {
        $Map->{ $r - 2 }{$c} = $p;
        $c++;
    }
}

# ENHANCE
for my $N ( 1 .. 50 ) {
    my $newM;

    # add a border around the map
    my $min_r = min keys %$Map;
    my $max_r = max keys %$Map;
    my ( $min_c, $max_c ) = ( 10e6, -1 );
    for my $r ( keys %$Map ) {
        $min_c = min( keys %{ $Map->{$r} } )
            if min( keys %{ $Map->{$r} } ) < $min_c;
        $max_c = max( keys %{ $Map->{$r} } )
            if max( keys %{ $Map->{$r} } ) > $max_c;
    }
    for my $r ( $min_r - 1 .. $max_r + 1 ) {
        for my $c ( $min_c - 1 .. $max_c + 1 ) {
            my $digit;
            for my $d (
		       [ -1, -1 ], [ -1, 0 ], [ -1, 1 ],
		       [  0, -1 ], [  0, 0 ], [  0, 1 ],
		       [  1, -1 ], [  1, 0 ], [  1, 1 ]
                )
            {
                my ( $rd, $cd ) = ( $r + $d->[0], $c + $d->[1] );

                # This is the key issue. For my input, index 0 mean
                # "light the pixel" while the last index mean "turn it
                # off". So every second iteration the infinite outside
                # "changes signs"
                if ( !$Map->{$rd}{$cd} ) {
                    if ( $N % 2 == 0 ) {
                        $digit .= '1';
                    }
                    else {
                        $digit .= '0';
                    }
                }
                elsif ( $Map->{$rd}{$cd} eq '#' ) {
                    $digit .= '1';
                }
                elsif ( $Map->{$rd}{$cd} eq '.' ) {
                    $digit .= '0';
                }
            }
            my $index = oct( '0b' . $digit );
            $newM->{$r}{$c} = $rule[$index];
        }

    }
    $Map = $newM;
    $ans{1} = count_map if $N == 2;
}
$ans{2} = count_map;

### FINALIZE - tests and run time
is( $ans{1}, 5846,  "Part 1: " . $ans{1} );
is( $ans{2}, 21149, "Part 2: " . $ans{2} );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub count_map {
    my $count = 0;
    for my $r ( keys %$Map ) {
        for my $c ( keys %{ $Map->{$r} } ) {
            $count++ if $Map->{$r}{$c} eq '#';
        }
    }
    return $count;

}

93 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 21 - Dirac Dice

[ AoC problem link ] [ Discussion ].

Day 21 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum any all min max/;
use Test::More;
use Memoize;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my %ans;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my %players;
for my $idx ( 0, 1 ) {
    $input[$idx] =~ m/^.*(\d+).*(\d+)$/;
    $players{$1} = { pos => $2, score => 0 };
}
sub dump_players;
my $rolls = 0;
GAME:
while (1) {

    #   say "==> $rolls" if $debug;
    for my $p ( 1, 2 ) {
        my $moves;
        for my $d ( 1 .. 3 ) {
            $rolls++;
            my $diceval = $rolls % 100;
            $moves += $diceval == 0 ? 100 : $diceval;
        }
        my $target = ( $players{$p}->{pos} + $moves ) % 10;
        $players{$p}->{score} += $target == 0 ? 10 : $target;
        last GAME if $players{$p}->{score} >= 1000;
        $players{$p}->{pos} = $target;

    }
}

$ans{1} = $rolls * min( map { $players{$_}->{score} } 1, 2 );

sub ucount;
memoize 'ucount';

# reset position from input
for my $idx ( 0, 1 ) {
    $input[$idx] =~ m/^.*(\d+).*(\d+)$/;
    $players{$1} = { pos => $2, score => 0 };
}

$ans{2} = max( ucount( 3, $players{1}->{pos}, $players{2}->{pos}, 0, 0 ) );

### FINALIZE - tests and run time
is( $ans{1},          989352, "Part 1: " . $ans{1} );
is( $ans{2}, 430229563871565, "Part 2: " . $ans{2} );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub dump_players {
    for my $p ( 1, 2 ) {
        printf(
            "Player %d: pos %2d score %3d\n",
            $p,
            $players{$p}->{pos},
            $players{$p}->{score}
        );
    }
}

sub ucount {
    # Credit: /u/EffectivePriority986
    # https://www.reddit.com/r/adventofcode/comments/rl6p8y/2021_day_21_solutions/hpe68q2/
    # assume turn is for player 1
    # in: rolls remaining for p1, p1 pos, p2 pos, p1 score, p2 score
    my ( $r, $p1, $p2, $s1, $s2 ) = @_;
    my ( $u1, $u2 );
    say join( ' ', ( $r, $p1, $p2, $s1, $s2 ) ) if $debug;
    unless ($r) {
        $s1 += $p1;
        if ( $s1 >= 21 ) {
            return ( 1, 0 );
        }
	# switch players 
        ( $u2, $u1 ) = ucount( 3, $p2, $p1, $s2, $s1 );
        return ( $u1, $u2 );
    }
    for my $d ( 1 .. 3 ) {
        my $np1 = $p1 + $d;
        $np1 = $np1 % 10 || 10;
        my ( $du1, $du2 ) = ucount( $r - 1, $np1, $p2, $s1, $s2 );
        $u1 += $du1;
        $u2 += $du2;

    }
    return ( $u1, $u2 );
}

94 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 22 - Reactor Reboot

[ AoC problem link ] [ Discussion ].

Day 22 - part 1


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum/;
use Data::Dump qw/dump/;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my @ranges;
for my $line (@input) {
    if ( $line
        =~ m/^(on|off) x=(-?\d+)\.\.(-?\d+),y=(-?\d+)\.\.(-?\d+),z=(-?\d+)\.\.(-?\d+)$/
        )
    {
        push @ranges,
            { cmd => $1, x => [ $2, $3 ], y => [ $4, $5 ], z => [ $6, $7 ] };
    }
    else {
        warn "can't parse: $line";
    }
}
dump @ranges if $debug;
my $Map;
for my $r (@ranges) {
    next
        unless ( $r->{x}[0] >= -50
        and $r->{x}[1] <= 50
        and $r->{y}[0] >= -50
        and $r->{y}[1] <= 50
        and $r->{z}[0] >= -50
        and $r->{z}[1] <= 50 );
    dump $r if $debug;
    for my $x ( $r->{x}[0] .. $r->{x}[1] ) {
        for my $y ( $r->{y}[0] .. $r->{y}[1] ) {
            for my $z ( $r->{z}[0] .. $r->{z}[1] ) {
                if ( $r->{cmd} eq 'on' ) {
                    $Map->{$x}{$y}{$z} = 1;
                }
                else {
                    $Map->{$x}{$y}{$z} = 0;
                }
            }
        }
    }
}
my $count = 0;
for my $x ( -50 .. 50 ) {
    for my $y ( -50 .. 50 ) {
        for my $z ( -50 .. 50 ) {
            $count++ if ( $Map->{$x}{$y}{$z} and $Map->{$x}{$y}{$z} == 1 );
        }
    }
}

### FINALIZE - tests and run time
is($count, 642125, "Part 1: $count");
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

70 lines [ Plain text ] [ ^Top ]

Day 22 - part 2


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum min max product/;
use Data::Dump qw/dump /;
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my @input;
my $file = $testing ? 'test2.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my @instr;
for my $line (@input) {
    if ( $line =~
 m/^(on|off) x=(-?\d+)\.\.(-?\d+),y=(-?\d+)\.\.(-?\d+),z=(-?\d+)\.\.(-?\d+)$/
        ) {
        my $state = $1;
        push @instr, { sign => $state eq 'on' ? 1 : -1,
		       x    => { min => $2, max => $3 },
		       y    => { min => $4, max => $5 },
		       z    => { min => $6, max => $7 } };
    }
    else {
        warn "can't parse: $line";
    }
}
sub intersect;
sub get_intersection;
sub get_volume;

my @construct = shift @instr;
while (@instr) {
    my $curr = shift @instr;
    my @intersections;
    for my $comp (@construct) {
        if ( intersect( $curr, $comp ) ) {
            push @intersections, get_intersection( $curr, $comp );
        }
        else {
            next;
        }
    }
    push @construct, @intersections;

    if ( $curr->{sign} == 1 ) {
        push @construct, $curr;
    }
}

my $sum;
for my $b (@construct) {
    $sum += get_volume($b) * $b->{sign};
}
say $sum;
### FINALIZE - tests and run time
is($sum, 1235164413198198, "Part 2: $sum");
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

sub intersect {
    my ( $b1, $b2 ) = @_;
    if (($b1->{x}{min} <= $b2->{x}{max} and $b1->{x}{max} >= $b2->{x}{min}) and
        ($b1->{y}{min} <= $b2->{y}{max} and $b1->{y}{max} >= $b2->{y}{min}) and
        ( $b1->{z}{min} <= $b2->{z}{max} and $b1->{z}{max} >= $b2->{z}{min} ))
      {
	  return 1;
      }
    else {
        return 0;
    }
}

sub get_intersection {
    my ( $b1, $b2 ) = @_;

    my $min_x = max( $b1->{x}{min}, $b2->{x}{min} );
    my $max_x = min( $b1->{x}{max}, $b2->{x}{max} );

    my $min_y = max( $b1->{y}{min}, $b2->{y}{min} );
    my $max_y = min( $b1->{y}{max}, $b2->{y}{max} );

    my $min_z = max( $b1->{z}{min}, $b2->{z}{min} );
    my $max_z = min( $b1->{z}{max}, $b2->{z}{max} );

    my $sign = $b1->{sign} * $b2->{sign};
    if ( $b1->{sign} == $b2->{sign} ) {
	$sign = -1 * $b1->{sign};
    }
    elsif ( $b1->{sign} == 1 and $b2->{sign} == -1 ) {
	$sign = 1;
    }
    return {
        sign => $sign,
        x    => { min => $min_x, max => $max_x },
        y    => { min => $min_y, max => $max_y },
        z    => { min => $min_z, max => $max_z },
    };
}

sub get_volume {
    my ($b) = @_;
    return product( map { $b->{$_}{max} - $b->{$_}{min} + 1 } qw/ x y z / );
}

100 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 23 - Amphipod

[ AoC problem link ] [ Discussion ].

Day 23 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use List::Util qw/sum none all/;
use Data::Dump qw/dump/;
use Test::More;
use Clone qw/clone/;
use Time::HiRes qw/gettimeofday tv_interval/;
use Array::Heap::PriorityQueue::Numeric;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my $part2   = shift @ARGV // 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my %amphipods = (
    A => { name => 'amber',  home_col => 3, cost => 1 },
    B => { name => 'bronze', home_col => 5, cost => 10 },
    C => { name => 'copper', home_col => 7, cost => 100 },
    D => { name => 'desert', home_col => 9, cost => 1000 }
);
my $Map;
my $state;
my $pos;
my $R = 0;
my $C = 0;

if ($part2) {
    splice( @input, 3, 0, ( '  #D#C#B#A#', '  #D#B#A#C#' ) );
}

for my $line (@input) {
    $C = 0;
    for my $t ( split( '', $line ) ) {
        $Map->{$R}{$C} = $t;
        if ( $t =~ m/[ABCD]/ ) {
            $state->{$R}{$C} = $t;
            $Map->{$R}{$C}   = '.';
        }
        $C++;
    }
    $R++;
}
sub move_and_cost;
sub dump_map;
sub serialize_state;
sub deserialize_state;

my $st = serialize_state($state);
say "R=$R, C=$C" if $debug;
dump_map($st) if $debug;
dump $state   if $debug;

my $goal_state = {
    2 => { 3 => "A", 5 => "B", 7 => "C", 9 => "D" },
    3 => { 3 => "A", 5 => "B", 7 => "C", 9 => "D" },
};
if ($part2) {
    $goal_state->{4} = { 3 => "A", 5 => "B", 7 => "C", 9 => "D" };
    $goal_state->{5} = { 3 => "A", 5 => "B", 7 => "C", 9 => "D" };
}

my $goal = serialize_state($goal_state);
my $pq   = Array::Heap::PriorityQueue::Numeric->new();
$pq->add( $st, 0 );
my $cost_so_far;
$cost_so_far->{$st} = 0;
my $ans;
my $round=0;
SEARCH:
while ( $pq->peek ) {
    my $cur = $pq->get();
    if ( $cur eq $goal ) {
        $ans = $cost_so_far->{$goal};
        last SEARCH;
    }

    # generate new states
    my $ret = move_and_cost($cur);
    next unless $ret;
    my @moves = @{$ret};
    for my $move (@moves) {

        my $new_cost = $cost_so_far->{$cur} + $move->{cost};
        if ( !exists $cost_so_far->{ $move->{state} }
            or $new_cost < $cost_so_far->{ $move->{state} } )
        {
            $cost_so_far->{ $move->{state} } = $new_cost;
            $pq->add( $move->{state}, $new_cost );
        }

    }
    $round++;

}
say "Rounds: $round";
### FINALIZE - tests and run time
if ( !$part2 ) {

    if ($testing) {
        is( $ans, 12521, "TESTING Part 1: $ans" );

    }
    else {
        is( $ans, 18300, "Part 1: $ans" );
    }
}
else {
    is( $ans, 50190, "Part 2: $ans" );
}

done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub move_and_cost {

    # in: a state string
    # out: a list of new state strings with costs
    my ($str) = @_;
    my $st = deserialize_state($str);

    my $ret;

    # scan the map, generate possible targets
    my @to_try;
    for my $r ( sort { $a <=> $b } keys %{$st} ) {
        for my $c ( sort { $a <=> $b } keys %{ $st->{$r} } ) {
            if ( $r == 1 ) {    # hallway, valid targets are burrows
                my $col = $amphipods{ $st->{$r}{$c} }->{home_col};

                for my $lvl ( 2 .. $R - 2 )
                {               # test every level in target burrow
                    if (none { exists $st->{$_}{$col} } ( 2 .. $lvl )
                        and all { exists $st->{$_}{$col}
			and $st->{$_}{$col} eq
				    $st->{$r}{$c}}( $lvl + 1 .. $R - 2 )) {
                        push @to_try,
                            { from => [ $r, $c ], to => [ $lvl, $col ] };
                    }
                }
            }
            else {    # we are starting from a burrow, see if we can move
                my $col = $amphipods{ $st->{$r}{$c} }->{home_col};
                if ($c == $col
                    and all { exists $st->{$_}{$c}
		    and $st->{$_}{$c} eq
				$st->{$r}{$c}} ( $r + 1 .. $R - 2 )){
                    # already in a target state, don't move
                    next;
                }
                elsif ( $c == $col and exists $st->{ $r - 1 }{$c} )
                {    #blocked from moving out
                    next;
                }
                my $can_goto_burrow = 0;
                for my $lvl ( 2 .. $R - 2 )
                {    # test every level in target burrow
                    if (none { exists $st->{$_}{$col} } ( 2 .. $lvl )
                        and all { exists $st->{$_}{$col}
			and $st->{$_}{$col}
				    eq $st->{$r}{$c}}( $lvl + 1 .. $R - 2 )) {
                        push @to_try,
                            { from => [ $r, $c ], to => [ $lvl, $col ] };
                        $can_goto_burrow++;
                    }
                }
                if ( !$can_goto_burrow ) {   # we need to move to the corridor
                    for my $tc ( 1, 2, 4, 6, 8, 10, 11 ) {
                        next if exists $st->{1}{$tc};    # occupied
                        push @to_try,
                            { from => [ $r, $c ], to => [ 1, $tc ] };
                    }
                }
            }
        }
    }

    # use BFS to check paths
    return undef unless @to_try;
    for my $try (@to_try) {
        my @queue = ( [ 0, $try->{from} ] );
        my %seen;
        my $shortest = undef;
    BFS:
        while (@queue) {
            my $cur  = shift @queue;
            my $step = $cur->[0];
            my ( $r, $c ) = @{ $cur->[1] };
            next if exists $seen{$r}{$c};
            $seen{$r}{$c}++;

            $step += 1;
            for my $d ( [ -1, 0 ], [ 1, 0 ], [ 0, -1 ], [ 0, 1 ] ) {
                my ( $dr, $dc ) = ( $r + $d->[0], $c + $d->[1] );
                if ( $Map->{$dr}{$dc} ne '.' or exists $st->{$dr}{$dc} ) {
                    next;
                }
                if ( $dr == $try->{to}[0] and $dc == $try->{to}[1] )
                {    # reached target
                    $shortest = $step;
                    last BFS;
                }
                push @queue, [ $step, [ $dr, $dc ] ];
            }
        }
        if ($shortest) {    # we have found a path

            # update the state for this move
            my ( $rf, $cf ) = map { $try->{from}[$_] } ( 0, 1 );
            my $type = $st->{$rf}{$cf};
            my ( $rt, $ct ) = map { $try->{to}[$_] } ( 0, 1 );
            my $cost = $shortest * $amphipods{$type}->{cost};

            my $new_st = clone $st;
            delete $new_st->{$rf}{$cf};
            $new_st->{$rt}{$ct} = $type;

            push @$ret, { cost => $cost, state => serialize_state($new_st) };
        }
    }
    return $ret if $ret;
}

sub dump_map {
    my ($str) = @_;
    my $st = deserialize_state($str);
    for my $r ( sort { $a <=> $b } keys %$Map ) {
        for my $c ( sort { $a <=> $b } keys %{ $Map->{$r} } ) {
            if ( $st->{$r}{$c} ) {
                print $st->{$r}{$c};
            }
            else {
                print $Map->{$r}{$c};
            }

        }
        print "\n";
    }
}

sub serialize_state {
    my ($st) = @_;
    my @ar;
    for my $r ( sort { $a <=> $b } keys %$st ) {
        for my $c ( sort { $a <=> $b } keys %{ $st->{$r} } ) {
            push @ar, join( ',', $r, $c, $st->{$r}{$c} );
        }
    }
    return join( ';', @ar );
}

sub deserialize_state {
    my ($str) = @_;
    my $st;
    for my $el ( split( ';', $str ) ) {
        my ( $r, $c, $t ) = split( ',', $el );
        $st->{$r}{$c} = $t;
    }
    return $st;
}

243 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 24 - Arithmetic Logic Unit

[ AoC problem link ] [ Discussion ].

Day 24 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';

# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE

=pod 

For the solution, I followed the excellent explanation here:

L

(via comment L by /u/snakebehindme)

As per the explanation, my values for {DIV}, {VALUE} and {OFFSET} were

(push) 13, 6 => PUSH  input[0] +  6
(push) 15, 7 => PUSH  input[1] +  7
(push) 15,10 => PUSH  input[2] + 10
(push) 11, 2 => PUSH  input[3] +  2
(pop)  -7,15 => POP:  input[4] must be == popped_value - 7
(push) 10, 8 => PUSH  input[5] +  8
(push) 10, 1 => PUSH  input[6] +  1
(pop)  -5,10 => POP:  input[7] must be == popped_value - 5
(push) 15, 5 => PUSH  input[8] +  5
(pop)  -3, 3 => POP:  input[9] must be == popped_value - 3
(pop)   0, 5 => POP: input[10] must be == popped_value - 0
(pop)  -5,11 => POP: input[11] must be == popped_value - 5
(pop)  -9,12 => POP: input[12] must be == popped_value - 9
(pop)   0,10 => POP: input[13] must be == popped_value - 0

Running the "stack" and matching each input value with the requirements above gives the following conditions that have to be met:

 input[0] = input[13] - 6
 input[2] = input[11] - 5
 input[4] =  input[3] - 5
 input[5] = input[10] - 8
 input[7] =  input[6] - 4
 input[8] =  input[9] - 2
input[12] =  input[1] - 2

Combining these to give the highest and lowest possible combination leads to

Part 1: 39494195799979
Part 2: 13161151139617

The code was used to validate these values.

=cut

my %reg;
my %cmd = (
    inp  => sub { my ( $in, $r ) = @_; $reg{$r} = $in },
    oper => \&oper,
    eql  => \&eql,
);

my @testprogs = (
    [ 'inp x', 'mul x -1' ],
    [ 'inp z', 'inp x', 'mul z 3', 'eql z x' ],
    [   'inp w',   'add z w', 'mod z 2', 'div w 2', 'add y w', 'mod y 2',
        'div w 2', 'add x w', 'mod x 2', 'div w 2', 'mod w 2'
    ],
);
my @tinputs = ( [7], [ 3, 9 ], [13] );
my @tchecks = (
    { w => 0, x => -7, y => 0, z => 0 },
    { w => 0, x => 9,  y => 0, z => 1 },
    { w => 1, x => 1,  y => 0, z => 1 }
);

for my $t (@testprogs) {
    my $prog;
    %reg = ( w => 0, x => 0, y => 0, z => 0 );

    for my $s (@$t) {
        push @$prog, [ split( /\s+/, $s ) ];
    }
    my $in = shift @tinputs;

    for my $l (@$prog) {
        if ( $l->[0] eq 'inp' ) {
            $cmd{inp}->( shift @$in, $l->[1] );
        }
        elsif ( $l->[0] eq 'eql' ) {
            $cmd{eql}->( $l->[1], $l->[2] );
        }
        else {
            $cmd{oper}->(@$l);
        }
    }
    my $check = shift @tchecks;
    my $nok   = 0;
    for my $k ( keys %reg ) {
        $nok++ unless $reg{$k} == $check->{$k};
    }
    is( $nok, 0, "test ok" );

}
my $prog;
%reg = ( w => 0, x => 0, y => 0, z => 0 );
for my $l (@input) {
    push @$prog, [ split /\s+/, $l ];
}
for my $ans ( '39494195799979', '13161151139617' ) {
    %reg = ( w => 0, x => 0, y => 0, z => 0 );
    my @vals = split( '', $ans );
    for my $s (@$prog) {
        if ( $s->[0] eq 'inp' ) {
            $cmd{inp}->( shift @vals, $s->[1] );

        }
        elsif ( $s->[0] eq 'eql' ) {
            $cmd{eql}->( $s->[1], $s->[2] );
        }
        else {
            $cmd{oper}->(@$s);
        }
    }
    is( $reg{z}, 0, "input $ans is correct" );

}
### FINALIZE - tests and run time
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub oper {
    my ( $op, $i, $j ) = @_;

    if ( exists $reg{$j} ) {
        $j = $reg{$j};

    }
    if ( $op eq 'add' ) {

        $reg{$i} = $reg{$i} + $j;
    }
    elsif ( $op eq 'mul' ) {
        $reg{$i} = $reg{$i} * $j;
    }
    elsif ( $op eq 'div' ) {
        $reg{$i} = int( $reg{$i} / $j );
    }
    elsif ( $op eq 'mod' ) {
        $reg{$i} = $reg{$i} % $j;
    }
}

sub eql {
    my ( $i, $j ) = @_;
    if ( exists $reg{$j} ) {
        $j = $reg{$j};
    }
    if ( $reg{$i} == $j ) {
        $reg{$i} = 1;
    }
    else {
        $reg{$i} = 0;
    }
}

148 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 25 - Sea Cucumber

[ AoC problem link ] [ Discussion ].

Day 25 - complete solution


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use Test::More;
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms;

my $start_time = [gettimeofday];
#### INIT - load input data from file into array

my $testing = 0;
my $debug   = 0;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; }

### CODE
my $Map;
sub dump_map;

my ( $R, $C ) = ( 0, 0 );
for my $line (@input) {
    $C = 0;
    for my $t ( split( '', $line ) ) {
        $Map->{$R}{$C} = $t unless $t eq '.';
        $C++;
    }
    $R++;

}
dump_map if $debug;

my $moved = 1;
my $steps = 0;
while ($moved) {
    no warnings 'uninitialized';
    say "==> $steps" if $steps % 25 == 0;

    $moved = 0;

    # east herd
    my $seen;
    for my $r ( sort { $a <=> $b } keys %$Map ) {
        for my $c ( sort { $a <=> $b } keys %{ $Map->{$r} } ) {
            if ( $Map->{$r}{$c} eq '>' and !defined $seen->{$r}{$c} ) {
                my $dc = ( $c + 1 ) % $C;
                if (    !defined $Map->{$r}{$dc}
                    and $Map->{$r}{$dc} ne '>'
                    and $Map->{$r}{$dc} ne 'v'
                    and !$seen->{$r}{$dc} )
                {
                    delete $Map->{$r}{$c};
                    $seen->{$r}{$c}++;
                    $Map->{$r}{$dc} = '>';
                    $seen->{$r}{$dc}++;
                    $moved++;
                }
            }
        }
    }

    # south herd
    $seen = undef;

    for my $r ( sort { $a <=> $b } keys %$Map ) {
        for my $c ( sort { $a <=> $b } keys %{ $Map->{$r} } ) {
            if ( $Map->{$r}{$c} eq 'v' and !defined $seen->{$r}{$c} ) {
                my $dr = ( $r + 1 ) % $R;
                if (    !defined $Map->{$dr}{$c}
                    and $Map->{$dr}{$c} ne '>'
                    and $Map->{$dr}{$c} ne 'v'
                    and !$seen->{$dr}{$c} )
                {
                    delete $Map->{$r}{$c};
                    $seen->{$r}{$c}++;
                    $Map->{$dr}{$c} = 'v';
                    $seen->{$dr}{$c}++;
                    $moved++;
                }
            }
        }
    }

    $steps++;
    if ($debug) {
        say "After $steps steps:";
        dump_map;
        print "\n";
    }

}

#say $steps;
### FINALIZE - tests and run time
is( $steps, 305, "Part 1: $steps" );
done_testing();
say sec_to_hms( tv_interval($start_time) );

### SUBS
sub sec_to_hms {
    my ($s) = @_;
    return sprintf(
        "Duration: %02dh%02dm%02ds (%.3f ms)",
        int( $s / ( 60 * 60 ) ),
        ( $s / 60 ) % 60,
        $s % 60, $s * 1000
    );
}

sub dump_map {
    for my $r ( 0 .. $R - 1 ) {
        for my $c ( 0 .. $C - 1 ) {
            print $Map->{$r}{$c} ? $Map->{$r}{$c} : '.';
        }
        print "\n";
    }
}

96 lines [ Plain text ] [ ^Top ]

Advent of Code 2021 day 31 - Template

[ AoC problem link ] [ Discussion ].

Day 31 - commented template


#! /usr/bin/env perl
use Modern::Perl '2015';
# useful modules
use List::Util qw/sum/;  # this module also has min, max, all etc
use Data::Dump qw/dump/; # simpler interface than Data::Dumper, does sorting
use Test::More; # simple testing harness
use Time::HiRes qw/gettimeofday tv_interval/;
sub sec_to_hms; # predeclare subs, but keep the definition at the end of the file

my $start_time = [gettimeofday]; # include reading and parsing in the total runtime
#### INIT - load input data from file into array

my $testing = 0; # set to true to get test data
my @input;
my $file = $testing ? 'test.txt' : 'input.txt'; 
open( my $fh, '<', "$file" );
while (<$fh>) { chomp; s/\r//gm; push @input, $_; } # file content is now in @input

### CODE
# add your awesome solution here!

### FINALIZE - tests and run time
is($file, 'input.txt', "File that has been read: ".$file); # use this to verify your answers between runs
done_testing();
say sec_to_hms(tv_interval($start_time));

### SUBS
sub sec_to_hms {  
    my ($s) = @_;
    return sprintf("Duration: %02dh%02dm%02ds (%.3f ms)",
    int( $s / ( 60 * 60 ) ), ( $s / 60 ) % 60, $s % 60, $s * 1000 );
}

20 lines [ Plain text ] [ ^Top ]

Generated on Tue Jan 4 10:06:02 2022 UTC.