Advent of Code 2016 solutions

This 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 2016 day 1

[ AoC problem link ] [ Discussion ].

Day 1 - part 1


#!/usr/bin/perl
use 5.016;
use warnings;
use autodie;

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

my %new_dir = ( N => { L => ['W',-1, 0],
		       R => ['E', 1, 0] },
		E => { L => ['N', 0, 1],
		       R => ['S', 0,-1] },
		S => { L => ['E', 1, 0],
		       R => ['W',-1, 0] },
		W => { L => ['S', 0,-1],
		       R => ['N', 0, 1] } );

my $pos = [ 'N', 0, 0 ];

my @dirs= split(/,\ /, $input[0]);

foreach my $turn ( @dirs ) {
    my ( $v, $l ) = $turn =~ m/(.)(\d+)/;
    say "$turn $v $l" if $testing;
    my $dest = $new_dir{$pos->[0]}->{$v};
    $pos->[0] = $dest->[0];
    $pos->[1] = $pos->[1] + $dest->[1] * $l;
    $pos->[2] = $pos->[2] + $dest->[2] * $l;
}

say join(' ', ('End position:',@{$pos}));
say "Distance: ", abs($pos->[1])+abs($pos->[2]);

30 lines [ Plain text ] [ ^Top ]

Day 1 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

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


my %new_dir = ( N => { L => ['W',-1, 0],
		       R => ['E', 1, 0] },
		E => { L => ['N', 0, 1],
		       R => ['S', 0,-1] },
		S => { L => ['E', 1, 0],
		       R => ['W',-1, 0] },
		W => { L => ['S', 0,-1],
		       R => ['N', 0, 1] } );

my $pos = [ 'N', 0, 0 ];
my $seen;
my $location = [$pos->[1], $pos->[2]];
my @dirs= split(/,\ /, $input[0]);

foreach my $turn ( @dirs ) {
    my ( $v, $l ) = $turn =~ m/(.)(\d+)/;

    my $direction = $new_dir{$pos->[0]}->{$v};
    my ( $x, $y ) = @{$pos}[1,2];
    if      ( $direction->[0] eq 'N' ) { # move positive Y
    	for ( my $i = $y; $i < $y+$l; $i++ ) {
	    $seen->{$x}->{$i}++ }
    } elsif ( $direction->[0] eq 'E' ) { # move positive X
    	for ( my $i = $x; $i < $x+$l; $i++ ) {
	    $seen->{$i}->{$y}++ }
    } elsif ( $direction->[0] eq 'S' ) { # move negative Y
    	for ( my $i = $y; $i > $y - $l; $i-- ) {
	    $seen->{$x}->{$i}++ }
    } elsif ( $direction->[0] eq 'W' ) { # move negative X
    	for ( my $i = $x; $i > $x - $l; $i-- ) {
	    $seen->{$i}->{$y}++ }
    } else {
    	die "what direction is this?! $direction->[0]";
    }
    # # check for intersections
    foreach my $x (keys %{$seen})  {
    	foreach  my $y (keys %{$seen->{$x}}) {
	    if ( $seen->{$x}->{$y} == 2 ) { 
		say "intersection at $x,$y, distance: ",abs($x)+abs($y);
		exit 0;
	    }
    	}
    }
    # set new starting position
    $pos->[0] = $direction->[0];
    $pos->[1] = $x + $direction->[1] * $l;
    $pos->[2] = $y + $direction->[2] * $l;
}


55 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 2

[ AoC problem link ] [ Discussion ].

Day 2 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT
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 $keypad = [ [ 1, 2, 3 ], [ 4, 5, 6 ], [ 7, 8, 9 ] ];
my $next_move = { U => [ 0,  1 ],
                  D => [ 0,  -1 ],
                  L => [ -1, 0 ],
                  R => [ 1,  0 ] };

# start with a Cartesian grid with the origin at 5:
# 1 2 3
# 4 5 6
# 7 8 9

my $key = [ 0, 0 ];
my $solution;
foreach my $line (@input) {
    my @instructions = split( //, $line );
    foreach my $move (@instructions) {
        my $next = [ $key->[0] + $next_move->{$move}->[0],
                     $key->[1] + $next_move->{$move}->[1] ];
        if ( abs( $next->[0] ) > 1 or abs( $next->[1] ) > 1 ) {
            next;
        } else {
            $key = $next;
        }
    }

    # To get the keys from the arrayref,
    # rotate 90 degrees counter-clockwise: ( x , y ) -> ( -y, x )
    # and translate [+1,+1]
    $solution .= $keypad->[ -$key->[1] + 1 ]->[ $key->[0] + 1 ];
}
say $solution;

34 lines [ Plain text ] [ ^Top ]

Day 2 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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

# Layout - circle in taxicab geometry!
#
#      1
#    2 3 4
#  5 6 7 8 9
#    A B C
#      D

# Cartesian coordinates, center the origin at 7, x,y for the keys as below

my $keypad = { -2 => {                       0 => 5 },
               -1 => {            -1 => 'A', 0 => 6, 1 => 2 },
                0 => { -2 => 'D', -1 => 'B', 0 => 7, 1 => 3, 2 => 1 },
                1 => {            -1 => 'C', 0 => 8, 1 => 4 },
                2 => {                       0 => 9 } };

my $next_move = { U => [  0,  1 ],
                  D => [  0, -1 ],
                  L => [ -1,  0 ],
                  R => [  1,  0 ] };

my $key = [ -2, 0 ];
my $solution;
foreach my $line (@input) {
    my @instructions = split( //, $line );
    foreach my $move (@instructions) {
        my $next = [ $key->[0] + $next_move->{$move}->[0],
                     $key->[1] + $next_move->{$move}->[1] ];
        if ( abs( $next->[0] ) + abs( $next->[1] ) > 2 ) {
            next;
        } else {
            $key = $next;
        }
    }
    $solution .= $keypad->{ $key->[0] }->{ $key->[1] };
}
say $solution;

35 lines [ Plain text ] [ ^Top ]

Day 2 - part 2, alternate version


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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
# Inspired by 
# https://www.reddit.com/r/adventofcode/comments/5g1hfm/2016_day_2_solutions/dap5cuj/
my $movemap = { 1 => { D => 3 },
                2 => { R => 3, D => 6 },
                3 => { U => 1, D => 7, L => 2, R => 4 },
                4 => { D => 8, L => 3 },
                5 => { R => 6 },
                6 => { U => 2, D => 'A', L => 5, R => 7 },
                7 => { U => 3, D => 'B', L => 6, R => 8 },
                8 => { U => 4, D => 'C', L => 7, R => 9 },
                9 => { L => 8 },
                A => { U => 6, R => 'B' },
                B => { U => 7, D => 'D', L => 'A', R => 'C' },
                C => { U => 8, L => 'B' },
                D => { U => 'B' } };

my $pos = 5;
my $solution;
foreach my $line (@input) {
    foreach my $move ( split( //, $line ) ) {
        if ( exists $movemap->{$pos}->{$move} ) {
            $pos = $movemap->{$pos}->{$move};
        }
    }
    $solution .= $pos;
}
say $solution;


34 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 3

[ AoC problem link ] [ Discussion ].

Day 3 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $count = 0;
foreach my $line (@input) {
    my @triple = sort { $a <=> $b } ( $line =~ m/(\d+)\s+(\d+)\s+(\d+)/ );
    $count++ if ( $triple[2] < $triple[0] + $triple[1] );
}
say "Number of triangles is $count";

16 lines [ Plain text ] [ ^Top ]

Day 3 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $data;
foreach my $line (@input) {
    my @row = $line =~ m/(\d+)\s+(\d+)\s+(\d+)/;
    # put each column into its own arrayref
    map { push @{ $data->[$_] }, $row[$_] } qw(0 1 2);
}
my $count = 0;
foreach my $col ( @{$data} ) {
    while ( @{$col} ) {
        my @triple = sort { $a <=> $b } ( splice @{$col}, 0, 3 );
        $count++ if ( $triple[2] < $triple[0] + $triple[1] );
    }
}
say "Number of triangles is $count";

24 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 4

[ AoC problem link ] [ Discussion ].

Day 4 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $sum = 0;
foreach my $line (@input) {
    my ( $code, $sector, $key ) = $line =~ m/(\D+)(\d+)\[(.*)\]/;
    my %freq;
    foreach my $c ( split( //, $code ) ) {
        next if $c eq '-';
        $freq{$c}++;
    }
    my @result;
    foreach ( sort { ( $freq{$b} <=> $freq{$a} ) || ( $a cmp $b ) }
              keys %freq )
    {
        push @result, $_;
    }
    if ( join( '', @result[ 0 .. 4 ] ) eq $key ) {
        $sum += $sector;
    }
}
say $sum;

29 lines [ Plain text ] [ ^Top ]

Day 4 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $sum = 0;
foreach my $line (@input) {
    my ( $code, $sector, $chk ) = $line =~ m/(\D+)(\d+)\[(.*)\]/;
    my %freq;
    foreach my $c ( split( //, $code ) ) {
        next if $c eq '-';
        $freq{$c}++;
    }
    my @result;
    foreach ( sort { ( $freq{$b} <=> $freq{$a} ) || ( $a cmp $b ) }
              keys %freq )
    {
        push @result, $_;
    }
    if ( join( '', @result[ 0 .. 4 ] ) eq $chk ) {    # valid code, not decoy
        my $key = $sector % 26;
        my @decode;
        foreach my $c ( split( //, $code ) ) {
            if ( $c eq '-' ) { push @decode, ' '; next; }
            my $ord = ord($c) + $key;
            if ( $ord > ord('z') ) { $ord -= 26 }
            push @decode, chr($ord);
        }

        # use `grep` on the output to find the desired string
        say join( '', @decode ), $sector;
    }
}


37 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 5

[ AoC problem link ] [ Discussion ].

Day 5 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
# this module is available from CPAN
use Digest::MD5 qw(md5_hex);

#### INIT
my $testing = 0;
my $input = $testing ? 'abc' : 'abbhdwsy';

### CODE
my $password = '';
my $i        = 0;

while ( length($password) < 8 ) {
    my $hash = md5_hex( $input . $i );
    if ( $hash =~ m/^00000/ ) {
        say "$i $hash" if $testing;
        $password .= ( split( //, $hash ) )[5];
    }
    $i++;
}
say $password;

17 lines [ Plain text ] [ ^Top ]

Day 5 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/sum notall/;
# this module is available from CPAN
use Digest::MD5 qw(md5_hex);

#### INIT
my $testing = 0;
my $input = $testing ? 'abc' : 'abbhdwsy';

### CODE
my @password = (undef) x 8;
my $i        = 0;

while ( notall { defined $_ } @password ) {
    my $hash = md5_hex( $input . $i );
    if ( $hash =~ m/^00000/ ) {

        # 6th char indicates position 0-7, 7th indicates character to
        # place there
        my $pos = ( split( //, $hash ) )[5];
        if ( $pos =~ m/[0-7]/ and !defined( $password[$pos] ) ) {
            $password[$pos] .= ( split( //, $hash ) )[6];

            # ANIMATE!
            say join( '', map { $_ ? $_ : '_' } @password );
        }
    }
    $i++;
}

say join( '', @password );

24 lines [ Plain text ] [ ^Top ]

Day 5 - part 2 with timer information


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/sum notall/;
use Time::HiRes qw/gettimeofday tv_interval/;
use Digest::MD5 qw(md5_hex);

#### INIT
my $testing = 0;
my $input = $testing ? 'abc' : 'abbhdwsy';

### CODE
my $t0 = [gettimeofday];
say " input: $input";
my @password = (undef) x 8;
my $i        = 0;

while ( notall { defined $_ } @password ) {
    my $hash = md5_hex( $input . $i );
    if ( $hash =~ m/^00000/ ) {

        # 6th char indicates position 0-7, 7th indicates character to
        # place there
        my $pos = ( split( //, $hash ) )[5];
        if ( $pos =~ m/[0-7]/ and !defined( $password[$pos] ) ) {
            $password[$pos] .= ( split( //, $hash ) )[6];

            # ANIMATE!
            #            say join( '', map { $_ ? $_ : '_' } @password );
        }
    }
    $i++;
}

my $elapsed = tv_interval($t0);
say 'answer: ', join( '', @password );
say sprintf( "%d hashes. Elapsed time: %d s, %.02f KH/s",
             $i, $elapsed, $i / 1_000 / $elapsed );

30 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 6

[ AoC problem link ] [ Discussion ].

Day 6 - complete solution


#!/usr/bin/perl
use 5.016;
use warnings;
use autodie;

#### INIT - load input data 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
# change value of $part for part 2
my $part = 1;
my $data;
foreach my $line (@input) {
    my @chars = split( //, $line );
    map { $data->[$_]->{ $chars[$_] }++ } ( 0 .. $#chars );
}

my $answer;
foreach my $hash ( @{$data} ) {
    my $sortings = { 1 => sub { $hash->{$a} <=> $hash->{$b} },
                     2 => sub { $hash->{$b} <=> $hash->{$a} }, };

    my @freq = sort { &{ $sortings->{$part} } } keys %{$hash};
    $answer .= pop @freq;
}
say $answer;

24 lines [ Plain text ] [ ^Top ]

Day 6 - complete solution, alternate map version


#!/usr/bin/perl
use 5.016;
use warnings;
use autodie;

#### INIT - load input data 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 $part = 1;
my $data;
my $sortings = { 1 => sub { $data->[$_]->{$a} <=> $data->[$_]->{$b} },
                 2 => sub { $data->[$_]->{$b} <=> $data->[$_]->{$a} }, };

foreach my $line (@input) {
    my @chars = split( //, $line );
    map { $data->[$_]->{ $chars[$_] }++ } ( 0 .. $#chars );
}

say join( '', map { ( sort { &{ $sortings->{$part} } }
		      keys %{ $data->[$_] } )[-1] } ( 0 .. $#{$data} ) );

20 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 7

[ AoC problem link ] [ Discussion ].

Day 7 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $count = 0;
foreach my $line (@input) {
    my (@hypernets) = $line =~ m/\[([^]]+)\]/g;
    my @parts = split( /\[.*?\]/, $line );
    my $taboo = 0;
    foreach my $hn (@hypernets) {
        $taboo++ if ( $hn =~ m/(.)(.)\2\1/ and $1 ne $2 );
    }
    next if $taboo;
    my $matches = 0;
    foreach my $part (@parts) {
        if ( $part =~ m/(.)(.)\2\1/ and $1 ne $2 ) {
            $matches++;
        }
    }
    $count++ if $matches > 0;
}
say $count;

28 lines [ Plain text ] [ ^Top ]

Day 7 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

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

### CODE
my $count = 0;
foreach my $line (@input) {
    my (@hypernets) = $line =~ m/\[([^]]+)\]/g;
    my @supernets = split( /\[.*?\]/, $line );

    my %compare;
    my $matches = 0;
    foreach my $hn (@hypernets) {
        my @part = split( //, $hn );
        for ( my $i = 0 ; $i < scalar @part - 2 ; $i++ ) {
            if (     $part[$i] eq $part[ $i + 2 ]
                 and $part[$i] ne $part[ $i + 1 ] )
            {
                $compare{ $part[$i] . $part[ $i + 1 ] . $part[ $i + 2 ] }++;
            }
        }
    }
    foreach my $sn (@supernets) {
        my @part = split( //, $sn );
        for ( my $i = 0 ; $i < scalar @part - 2 ; $i++ ) {
            if (     $part[$i] eq $part[ $i + 2 ]
                 and $part[$i] ne $part[ $i + 1 ] )
            {
                if ( exists $compare{ $part[ $i + 1 ]
                             . $part[$i]
                             . $part[ $i + 1 ] } )
                {
                    $matches++;
                }
            }
        }
    }
    $count++ if $matches > 0;

}

say $count;

44 lines [ Plain text ] [ ^Top ]

Day 7 - part 2, alternative with regexp lookahead


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

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

### CODE
my $count = 0;
foreach my $line (@input) {
    my (@hypernets) = $line =~ m/\[([^]]+)\]/g;
    my @supernets = split( /\[.*?\]/, $line );
    my %compare;
    my $matches = 0;
    foreach my $hn (@hypernets) {

	# following regex cargo-cult copied from
	# http://stackoverflow.com/questions/14259677/matching-two-overlapping-patterns-with-perl
        while ( $hn =~ m/(?=(.)(.)\1)/g ) {
            next if $1 eq $2;
            $compare{ $1 . $2 . $1 }++;
        }
    }
    foreach my $sn (@supernets) {
        while ( $sn =~ m/(?=(.)(.)\1)/g ) {
            next if $1 eq $2;
            if ( exists $compare{ $2 . $1 . $2 } ) {
                $matches++;
            }
        }
    }
    $count++ if $matches > 0;
}

say $count;

35 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 8

[ AoC problem link ] [ Discussion ].

Day 8 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 ( $max_col, $max_row ) = $testing ? ( 7, 3 ) : ( 50, 6 );

my $M;
for my $r ( 0 .. $max_row - 1 ) {
    for my $c ( 0 .. $max_col - 1 ) {
        $M->[$c]->[$r] = 0;
    }
}

sub rect {
    my ( $col, $row ) = @_;
    for my $r ( 0 .. $row - 1 ) {
        for my $c ( 0 .. $col - 1 ) {
            $M->[$r]->[$c] = 1;
        }
    }
}

sub rotate_row {
    my ( $row, $shift ) = @_;
    my @current_row = @{ $M->[$row] };
    my @new_row;
    for my $i ( 0 .. $#current_row ) {
        $new_row[ ( $i + $shift ) % $max_col ]
            = $current_row[$i] ? $current_row[$i] : 0;
    }
    $M->[$row] = \@new_row;
}

sub rotate_col {
    my ( $col, $shift ) = @_;
    my @current_col;
    for my $r ( 0 .. $max_row - 1 ) {
        push @current_col, $M->[$r]->[$col];
    }
    my @new_col;
    for my $i ( 0 .. $#current_col ) {
        $new_col[ ( $i + $shift ) % $max_row ]
            = $current_col[$i] ? $current_col[$i] : 0;
    }
    for my $r ( 0 .. $max_row - 1 ) {
        $M->[$r]->[$col] = $new_col[$r];
    }
}

sub display {
    for my $r ( 0 .. $max_row - 1 ) {
        print '    ';
        for my $c ( 0 .. $max_col - 1 ) {
            if ( defined( $M->[$r]->[$c] ) and $M->[$r]->[$c] == 1 ) {
                print '0';
            } else {
                print ' ';
            }
        }
        print "\n";
    }
}

sub count_cells {
    my $count = 0;
    for my $r ( 0 .. $max_row - 1 ) {
        for my $c ( 0 .. $max_col - 1 ) {
            if ( defined( $M->[$r]->[$c] ) and $M->[$r]->[$c] == 1 ) {
                $count++;
            }
        }
    }
    return $count;
}

foreach my $line (@input) {
    if ( $line =~ m/^rect (\d+)x(\d+)/ ) {
        rect( $1, $2 );
    } elsif ( $line =~ m/^rotate column x=(\d+) by (\d+)/ ) {
        rotate_col( $1, $2 );
    } elsif ( $line =~ m/^rotate row y=(\d+) by (\d+)/ ) {
        rotate_row( $1, $2 );
    } else {
        die "can't parse $line";
    }
}
say "    Lit pixels: ", count_cells();
display();

87 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 9

[ AoC problem link ] [ Discussion ].

Day 9 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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
# we will only have one line for "real" input, this is for testing
foreach my $line (@input) {
    my @stream = split( //, $line );
    my $count = 0;
    while (@stream) {
        my $c = shift @stream;
        if ( $c eq '(' ) {
            # process marker
            my $marker = $c;
            my $t      = shift @stream;

            while ( $t ne ')' ) { # get end
                $marker .= $t;
                $t = shift @stream;
            }
            $marker .= ')';

            # parse marker
            my ( $part, $rep ) = ( 0, 0 );
            if ( $marker =~ /\((\d+)x(\d+)\)/ ) {
                ( $part, $rep ) = ( $1, $2 );
            } else { # this is not a marker, instead it's chars enclosed in parens
                $count += length $marker;
                next;
            }

            # read input and decompress
            my @d = splice @stream, 0, $part;
            $count += ( scalar @d ) * $rep;

        } else {
            $count++;
        }
    }
    say $count;
}


41 lines [ Plain text ] [ ^Top ]

Day 9 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/sum/;
use Data::Dumper;

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

### CODE

sub get_count {
    my @ary = @_;
    my $count = 0;
    while (@ary) {
        my $c = shift @ary;
        if ( $c eq '(' ) {
            my $marker = $c;
            my $t      = shift @ary;
            while ( $t ne ')' ) {
                $marker .= $t;
                $t = shift @ary;
            }
            $marker .= ')';
            my ( $part, $rep ) = ( 0, 0 );
            if ( $marker =~ /\((\d+)x(\d+)\)/ ) {
                ( $part, $rep ) = ( $1, $2 );
            } else {
                $count += length $marker;
            }
            my @d = splice @ary, 0, $part;
            $count += get_count(@d) * $rep;
        } else {
            $count++;
        }
    }
    return $count;
}

# we will only have one line for "real" input, the foreach loop is for testing
foreach my $line (@input) {
    my @stream = split( //, $line );
    say get_count(@stream);
}

43 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 10

[ AoC problem link ] [ Discussion ].

Day 10 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 %state;
my @goal = $testing ? ( 2, 5 ) : ( 17, 61 );
while ( scalar @input > 0 ) {
    my $cmd = shift @input;
    if ( $cmd =~ m/^value/ ) {
        my ( $init, $recip ) = $cmd =~ /value (\d+) goes to (bot \d+)/;
        push @{ $state{$recip} }, $init;
    } elsif ( $cmd =~ m/^bot.*low.*high/ ) {
        my ( $giver, $lo, $hi )
            = $cmd
            =~ /(bot \d+) gives low to (\S+\s\d+) and high to (\S+\s\d+)/;
        my @c = sort { $a <=> $b } @{ $state{$giver} }
            if exists $state{$giver};
        if ( scalar @c != 2 ) {
            push @input, $cmd;
        } else {
            push @{ $state{$lo} }, shift @c;
            push @{ $state{$hi} }, shift @c;
        }
    } else {
        die "can't parse $cmd";
    }
}

my $part2 = 1;
foreach my $e ( keys %state ) {
    my @a = sort { $a <=> $b } @{ $state{$e} };
    say "Part 1: $e" if ( join( '', @a ) eq join( '', @goal ) );
    if ( $e eq 'output 0' or $e eq 'output 1' or $e eq 'output 2' ) {
        $part2 *= ${ $state{$e} }[0];
    }
}

say "Part 2: $part2";

42 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 11

[ AoC problem link ] [ Discussion ].

Day 11 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/sum all/;
use Algorithm::Combinatorics qw/combinations/;

#### INIT - load input data into array
my $testing = 0;
my $part2 = shift || 0;

# state->[0] = step, $state->[1] = elevator pos
# then a list of hashes with elements
# g = generator, m = microchip
# testing: h=Hydrogen l=Lithium
# t=Thulium p=Plutonium s=Strontium r=Ruthenium o=prOmethium
my $states;
my $target;

if ($testing) {
    $states = [
        {  steps => 0,
           floor => 0,
           state => [{ mh => 1, ml => 1, el => 1 },
		     { gh => 1 },
		     { gl => 1 },
                      {} ] } ];
    $target = 4;

} else {
    $states = [ { steps => 0,
                  floor => 0,
                  state => [ { gt => 1, mt => 1, gp => 1, gs => 1, el => 1 },
                             { mp => 1, ms => 1 },
                             { go => 1, mo => 1, gr => 1, mr => 1 },
                             {} ] } ];
    $target = 10;
    if ($part2) {
        $states->[0]->{state}->[0]->{ge}++;
        $states->[0]->{state}->[0]->{me}++;
        $states->[0]->{state}->[0]->{gd}++;
        $states->[0]->{state}->[0]->{md}++;
        $target += 4;
    }
}


### CODE ########################################
my %seen;

### SUBS ########################################
sub is_ok {
    my ($a) = @_;

    # none or 1 ok
    return 1 if ( !defined($a) );
    return 1 if ( scalar @{$a} <= 1 );

    # all generators ok
    return 1 if ( all { ( split( //, $_ ) )[0] eq 'g' } @$a );

    # all microchips ok
    return 1 if ( all { ( split( //, $_ ) )[0] eq 'm' } @$a );
    my %set;
    my @singles;
    for my $i ( sort @$a ) {
        my @c = split( //, $i );
        push @{ $set{ $c[1] } }, $c[0];
    }

    foreach my $el ( keys %set ) {
        next
            if scalar @{ $set{$el} } == 2;
        push @singles, $set{$el}->[0];
    }
    if (all {
            $_ eq 'g';
        }
        @singles )
    {
        return 1;
    } else {
        return 0;
    }
}

sub dump_state {
    my ($s) = @_;
    say "S: $s->{steps} F: $s->{floor}";
    for my $f ( @{ $s->{state} } ) {
        my $rest = $target - scalar keys %{$f};
        say '[ ', join( ' ', ( sort keys %{$f} ), ( '...' x $rest ) ), ' ]';
    }
    say join( '', '-' x 16 );
}

sub stringify_state {
    my ($state) = @_;
    return
        '<'
        . join( '|', map { join( '', sort keys %{$_} ) } @{$state} ) . '>';
}

########################################

my $count = 0;

LOOP: while (1) {

    my $move = shift @{$states} || die "no more states!";

    my $str = stringify_state( $move->{state} );
    if ( exists $seen{$str} ) {
        next;
    } else {
        $seen{$str}++;
    }

    my $steps      = $move->{steps};
    my $from_floor = $move->{floor};
    my $current    = $move->{state};

    delete $current->[$from_floor]->{el};

    my %from_items = %{ $current->[$from_floor] };

    # get the combinations of stuff to move from the source floor

    my @items = combinations( [ keys %from_items ], 1 );
    if ( scalar keys %from_items >= 2 ) {
        push @items, combinations( [ keys %from_items ], 2 );
    }
    @items = grep { is_ok($_) } @items;
    next unless scalar @items > 0;
    $steps += 1;

    # move up or down, if possible
STATE: for my $to_floor ( $from_floor - 1, $from_floor + 1 ) {

        next if ( $to_floor < 0 or $to_floor > 3 );
        for my $item_list (@items) {

            my $new = [ {}, {}, {}, {} ];

            # unchanged floors are copied over
            my @unchanged
                = grep { $_ != $to_floor and $_ != $from_floor } ( 0 .. 3 );
            map { $new->[$_] = $current->[$_] } @unchanged;

            # remove from origin floor
            my $invalid_flag = 0;
            for my $k ( keys %{ $current->[$from_floor] } ) {
                if ( grep { $k eq $_ } @{$item_list} ) {
                    next;
                } else {
                    $new->[$from_floor]->{$k}++;
                }
            }

            if ( !is_ok( [ keys %{ $new->[$from_floor] } ] ) ) {
                $invalid_flag += 1;
            }

            # add to dest floor
            for my $k ( keys %{ $current->[$to_floor] } ) {
                $new->[$to_floor]->{$k}++;
            }
            for my $j ( @{$item_list} ) {
                $new->[$to_floor]->{$j}++;
            }
            if ( !is_ok( [ keys %{ $new->[$to_floor] } ] ) ) {
                $invalid_flag += 1;
            }

            # check all are valid
            next unless ( $invalid_flag == 0 );

            # check we have reached goal
            if ( scalar keys %{ $new->[3] } == $target ) {
                say "$steps";
                last LOOP;
            }

            # heuristic: don't move down 2 items
            if (     ( $to_floor < $from_floor )
                 and ( scalar keys %{ $new->[$to_floor] } )
                 - ( scalar keys %{ $current->[$to_floor] } ) > 1 )
            {
                next;
            }

            # add elevator, then add to queue
            $new->[$to_floor]->{el}++;
            my $new_state = { steps => $steps,
                              floor => $to_floor,
                              state => $new };

            push @{$states}, $new_state;

        }
    }
    $count++;
}

157 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 12

[ AoC problem link ] [ Discussion ].

Day 12 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my $part    = 2;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
{
    open( my $fh, '<', "$file" );
    while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
}

### CODE
my %reg = map { $_ => 0 } qw(a b c d);
$reg{c} = 1 unless $part == 1;

my @instr;
while (@input) {
    my ( $cmd, $arg1, $arg2 );
    my $line = shift @input;
    if ( $line =~ m/^(inc|dec) (.)$/ ) { push @instr, [ $1, $2, undef ] }
    elsif ( $line =~ /^cpy (\S+) (\S+)$/ ) { push @instr, [ 'cpy', $1, $2 ] }
    elsif ( $line =~ /^jnz (\S+) (-?\d+)$/ ) {
        push @instr, [ 'jnz', $1, $2 ];
    } else {
        die "cannot parse $line";
    }
}

my $pos = 0;
while ( $pos >= 0 and $pos <= $#instr ) {
    my ( $cmd, $a1, $a2 ) = @{ $instr[$pos] };
    if ( $cmd eq 'inc' ) {
        $reg{$a1} += 1;
        $pos++;
    } elsif ( $cmd eq 'dec' ) {
        $reg{$a1} -= 1;
        $pos++;
    } elsif ( $cmd eq 'cpy' ) {
        # can either copy integer or content of other register
        if   ( $a1 =~ /\d+/ ) { $reg{$a2} = $a1 }
        else                  { $reg{$a2} = $reg{$a1} }
        $pos++;
    } elsif ( $cmd eq 'jnz' ) {
        # value to compare can be integer (one case) or content of register
        if ( $a1 =~ /\d+/ ) { $pos = $pos + $a2 }
        elsif ( $a1 =~ /[a-d]/ ) {
            if ( $reg{$a1} != 0 ) { $pos = $pos + $a2 }
            else                  { $pos++ }
	}
    }
}
say $reg{a};

49 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 13

[ AoC problem link ] [ Discussion ].

Day 13 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my ( $input, $target ) = ( 1358, [ 31, 39 ] );
if ($testing) { $input = 10; $target = [ 7, 4 ]; }

### CODE
my $maze;
my $seen;

sub count_ones {

    # http://docstore.mik.ua/orelly/perl/cookbook/ch02_05.htm
    my $str = unpack( "B32", pack( "N", shift ) );
    $str =~ s/^0+(?=\d)//;

    my $count = 0;
    for my $c ( split( //, $str ) ) {
        $count++ if ( $c == 1 );
    }
    return $count;
}

sub is_open {
    my ( $x, $y ) = @_;
    if ( $x < 0 or $y < 0 ) { return 0 }
    if ( exists $maze->{$x}->{$y} ) {
        return $maze->{$x}->{$y};
    }

    my $fact = ( $x * $x + 3 * $x + 2 * $x * $y + $y + $y * $y );
    $fact += $input;
    my $ones = count_ones($fact);
    if ( $ones % 2 == 0 ) {
        $maze->{$x}->{$y} = 1;
        return 1;
    } else {
        $maze->{$x}->{$y} = 0;
        return 0;
    }
}

my @states = ( [ 0, [ 1, 1 ] ] );
LOOP: {
    while (@states) {
        my $move = shift @states;
        my $step = $move->[0];
        my ( $x, $y ) = @{ $move->[1] };

        if ( exists $seen->{$x}->{$y} ) {
            next;
        } else {
            $seen->{$x}->{$y}++;
        }

        # try to move
        $step += 1;
        my @new;
        push @new,
	  ( [ $x + 1, $y ], [ $x - 1, $y ],
	    [ $x, $y + 1 ], [ $x, $y - 1 ] );

        while (@new) {
            my $el = shift @new;
            my ( $new_x, $new_y ) = @$el;
            if ( is_open( $new_x, $new_y ) ) {
                if (     $new_x == $target->[0]
                     and $new_y == $target->[1] )
                {

                    #break out reporting sucess
                    say "steps: $step";
                    last LOOP;
                }
                push @states, [ $step, $el ];
            }
        }

    }
}

68 lines [ Plain text ] [ ^Top ]

Day 13 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my ( $input, $target ) = ( 1358, [ 31, 39 ] );
if ($testing) { $input = 10; $target = [ 7, 4 ]; }

### CODE
my $maze;
my $seen;

sub count_ones {    # http://docstore.mik.ua/orelly/perl/cookbook/ch02_05.htm
    my $str = unpack( "B32", pack( "N", shift ) );
    $str =~ s/^0+(?=\d)//;
    my $count = 0;
    for my $c ( split( //, $str ) ) {
        $count++ if ( $c == 1 );
    }
    return $count;
}

sub is_open {
    my ( $x, $y ) = @_;
    if ( $x < 0 or $y < 0 ) { return 0 }
    if ( exists $maze->{$x}->{$y} ) {
        return $maze->{$x}->{$y};
    }

    my $fact = ( $x * $x + 3 * $x + 2 * $x * $y + $y + $y * $y );
    $fact += $input;
    my $ones = count_ones($fact);
    if ( $ones % 2 == 0 ) {
        $maze->{$x}->{$y} = 1;
        return 1;
    } else {
        $maze->{$x}->{$y} = 0;
        return 0;
    }
}

my @states = ( [ 0, [ 1, 1 ] ] );

while (@states) {
    my $move = shift @states;
    my $step = $move->[0];
    my ( $x, $y ) = @{ $move->[1] };

    if ( exists $seen->{$x}->{$y} ) {
        next;
    } else {
        $seen->{$x}->{$y}++;
    }

    # try to move
    $step += 1;
    next if $step > 50;
    my @new;
    push @new,
        ( [ $x + 1, $y ], [ $x - 1, $y ], [ $x, $y - 1 ], [ $x, $y + 1 ] );
    while (@new) {
        my $el = shift @new;
        my ( $new_x, $new_y ) = @$el;
        if ( is_open( $new_x, $new_y ) ) {
            push @states, [ $step, $el ];
        }
    }
}

my $count = 0;
for my $x ( keys %{$seen} ) {
    for my $y ( keys %{ $seen->{$x} } ) {
        $count++;
    }
}
say $count;

65 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 14

[ AoC problem link ] [ Discussion ].

Day 14 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use Digest::MD5 qw(md5_hex);

#### INIT
my $debug   = 0;
my $testing = 0;
my $salt    = $testing ? 'abc' : 'qzyelonm';

# pass an argument for part 2
my $part2 = shift || undef;

### CODE
my $index  = 0;
my @keys   = ();
my %lookup = ();

#### yak-shaving debug output 
sub dump_state {
    say "  /// Index: $index";
    say map {
        sprintf( "%3x: %3d", $_, $lookup{$_} ? scalar @{ $lookup{$_} } : 0 )
    } ( 0 .. 7 );
    say map {
        sprintf( "%3x: %3d",
                 $_,
                 $lookup{ sprintf( "%x", $_ ) }
                 ? scalar @{ $lookup{ sprintf( "%x", $_ ) } }
                 : 0 )
    } ( 8 .. 15 );
    say '  Last 3 keys: ... ',
      join( ', ', ( sort { $a <=> $b } @keys )[ -3 .. -1 ] ), ' )';
}

sub dbg_line {
    my ($str, $c, $hex) = @_;
    say sprintf("%5d %6s %s %s", $index, $str, $c, $hex);
}
###############

while ( scalar @keys <= 70 ) {
    my $hex = md5_hex( $salt . $index );
    if ($part2) {
        for ( 1 .. 2016 ) { $hex = md5_hex($hex) }
    }

    # check for triples
    if ( $hex =~ m/(.)\1{2}/ ) {
	dbg_line('triple', $1, $hex) if $debug;
        push @{ $lookup{$1} }, $index;
    }

    # check for quints
    if ( $hex =~ m/(.)\1{4}/ ) {
	dbg_line('quint', $1, $hex) if $debug;
        if ( exists $lookup{$1} ) {

            # get the lists of indexes found for this hex char
            while ( @{ $lookup{$1} } ) {
                my $el = shift @{ $lookup{$1} };
                if ( $index == $el ) {
                    say "  **> skip $el for now, check later" if $debug;
                    next;
                } elsif ( $index - $el < 1000 ) {
                    say "  ==> add $el to keys" if $debug;
                    push @keys, $el;
                } else {
                    say "  --> $el too old, discard" if $debug;
                }
            }
        }
	# finally add the quint to the lookup
        push @{ $lookup{$1} }, $index;
    }
    $index++;
    if ( $debug and $index % 1_000 == 0 ) { dump_state }
}
@keys = sort { $a <=> $b } @keys;
say '==>', $keys[63];

66 lines [ Plain text ] [ ^Top ]

Day 14 - complete solution, alternative implementation


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use Digest::MD5 qw(md5_hex);

#### INIT
my $debug   = 1;
my $testing = 0;
my $salt    = $testing ? 'abc' : 'qzyelonm';

# mine: 'qzyelonm';
# Tenjou: 'yjdafjpo'
# pass an argument for part 2
my $part2 = shift || undef;

### CODE
my $index  = 0;
my @keys   = ();
my %lookup = ();

#### yak-shaving debug output
sub dump_state {
    say "  /// Index: $index";
    say map {
        sprintf( "%3x: %3d", $_, $lookup{$_} ? scalar @{ $lookup{$_} } : 0 )
    } ( 0 .. 7 );
    say map {
        sprintf( "%3x: %3d",
                 $_,
                 $lookup{ sprintf( "%x", $_ ) }
                 ? scalar @{ $lookup{ sprintf( "%x", $_ ) } }
                 : 0 )
    } ( 8 .. 15 );
    say '  Last 3 keys: ... ',
        join( ', ', ( sort { $a <=> $b } @keys )[ -3 .. -1 ] ), ' )';
}

sub dbg_line {
    my ( $str, $c, $hex ) = @_;
    say sprintf( "%5d %6s %s %s", $index, $str, $c, $hex );
}
###############

# code below inspired by this comment
# https://www.reddit.com/r/adventofcode/comments/5iaszm/how_long_does_day_14_take_to_run/db7id7f/

my %keys;
for ( my ( $index, $end ) = ( 0, 1e99 ) ; $index < $end ; $index++ ) {

    my $hex = md5_hex( $salt . $index );
    if ($part2) {
        for ( 1 .. 2016 ) { $hex = md5_hex($hex) }
    }

    # check for quints
    while ( $hex =~ m/(.)(?=\1\1\1\1)/g ) {
        next unless defined $lookup{$1};
        my @list = @{ $lookup{$1} };
        delete $lookup{$1};
        for my $candidate (@list) {
            next if $index - $candidate > 1000;
            $keys{$candidate}++;
            if ( keys %keys == 64 ) {
                $end = $index + 1000;
            }
        }
    }
    # add triples
    if ( $hex =~ m/(.)\1\1/ ) {
        push @{ $lookup{$1} }, $index;
    }
}
say '' . ( sort { $a <=> $b } keys %keys )[ 64 - 1 ];

55 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 15

[ AoC problem link ] [ Discussion ].

Day 15 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/all max/;

#### INIT - load input data into array
my $testing = 0;
my $part2   = shift || 0; # call with any argument for part 2

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

### CODE
my %discs;

for my $line (@input) {

    my ( $disc_id, $slots, $initial )
        = $line
        =~ m/^Disc \#(\d+) has (\d+) positions\; at time=0, it is at position (\d+)\.$/;
    $discs{$disc_id} = { slots => $slots, pos => $initial };
}

if ($part2) {
    my $new = max( keys %discs ) + 1;
    $discs{$new} = { slots => 11, pos => 0 };
}

my $t0 = 0;
while (1) {
    my @vec;
    for my $d ( sort { $a <=> $b } keys %discs ) {
        my $t   = $t0 + $d;
        my $pos = $discs{$d}->{pos} + $t;
        push @vec, $pos % $discs{$d}->{slots};

    }

    if ( all { $_ == 0 } (@vec) ) {
        say $t0;
        last;
    }
    $t0++;
}

37 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 16

[ AoC problem link ] [ Discussion ].

Day 16 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $part2 = shift || 0;
my $testing = 0;
my $input;
my $target_length;
if ($testing) {
    $input         = '10000';
    $target_length = 20;
} else {
    $input = '10111100110001111';
    $target_length = $part2 ? 35651584 : 272;
}
### CODE
sub generate_curve {
    my ( $str, $target ) = @_;
    return $str if length($str) >= $target;
    my $cpy = $str;
    my $out = $str . '0';

    # fsck regex
    for my $c ( reverse split( //, $cpy ) ) {
        if   ( $c == 1 ) { $out .= '0' }
        else             { $out .= '1' }
    }
    generate_curve( $out, $target );
}

sub generate_checksum {
    my ($str) = @_;
    my $out;
    my @a = split( //, $str );
    while (@a) {
        my @pair = splice( @a, 0, 2 );
        if   ( $pair[0] == $pair[1] ) { $out .= '1' }
        else                          { $out .= '0' }
    }
    if ( ( length $out ) % 2 == 0 ) {
        generate_checksum($out);
    } else {
        return $out;
    }
}
if ($testing) {
    for my $teststr (qw/1 0 11111 111100001010/) {
        say $teststr, ' becomes ',
            generate_curve( $teststr, 2 * length($teststr) + 1 ) . '.';
    }
    say generate_checksum('110010110100');
}

my $curve = generate_curve( $input, $target_length );
if ( length $curve > $target_length ) {
    $curve = substr( $curve, 0, $target_length );
}
say generate_checksum($curve);

53 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 17

[ AoC problem link ] [ Discussion ].

Day 17 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/max/;
use Digest::MD5 qw/md5_hex/;

#### INIT - load input data into array
my $testing = 0;
my $input;
if ( $testing ) {
    $input = 'hijkl';
} else {
    $input = shift || 'yjjvjgan';
}


### CODE
my @sequence = ( [ '', 0, 0 ] );
my @solutions;
LOOP: while (@sequence) {
    # grab the door configuration based on current path
    my $current = shift @sequence;
    my $path    = $current->[0];
    my ( $cur_x, $cur_y ) = @{$current}[ 1, 2 ];
    my $hex = md5_hex( $input . $path );

    # U D L R
    my ( $u, $d, $l, $r ) = $hex =~ m/^(.)(.)(.)(.)/;

    # generate potential paths
    my @tries;
    if ( $u =~ m/[b-f]/ ) { push @tries, [ 'U', $cur_x, $cur_y - 1 ] }
    if ( $d =~ m/[b-f]/ ) { push @tries, [ 'D', $cur_x, $cur_y + 1 ] }
    if ( $l =~ m/[b-f]/ ) { push @tries, [ 'L', $cur_x - 1, $cur_y ] }
    if ( $r =~ m/[b-f]/ ) { push @tries, [ 'R', $cur_x + 1, $cur_y ] }
    while (@tries) {
        my $next = shift @tries;

        # are the moves legal?
        if (    $next->[1] < 0
             or $next->[1] > 3
             or $next->[2] < 0
             or $next->[2] > 3 )
        {
            next;
        }
        if ( $next->[1] == 3 and $next->[2] == 3 ) {

            # say $path.$next->[0];
            push @solutions, $path . $next->[0];
            next;
        }
        push @sequence, [ $path . $next->[0], $next->[1], $next->[2] ];
    }
}
if (scalar @solutions == 0 ) {
    say "input $input didn't result in valid path";
    exit 1;
}

say "Part 1: ", $solutions[0];
say "Part 2: ", max map {length $_} @solutions;

52 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 18

[ AoC problem link ] [ Discussion ].

Day 18 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $part2 = shift || 0;
my $testing = 0;
my @input;
my $target = $testing? 10 : 40;
$target =  400_000 if $part2;
my $file = $testing ? 'test.txt' : 'input.txt';
{
    open( my $fh, '<', "$file" );
    while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
}

### CODE
my @rows;
my $safe_count = 0;
push @rows, $input[0];

while ( scalar @rows < $target ) {
    my @prev = split(//,$rows[-1]);
    my $new;
    for my $i (0..$#prev ){
	my ( $left, $center, $right ) = map {$prev[$i+$_]} (-1,0,1);
	if ( $i-1 < 0 ) { $left = '.' }
	if ( $i+1 > $#prev ) {$right = '.' }
	# apply rules
	if ( $left eq '^' and $center eq '^' and $right ne '^' ) {
	    $new .= '^'
	} elsif ( $left ne '^' and $center eq '^' and $right eq '^' ) {
	    $new .= '^'
	} elsif ( $left eq '^' and $center ne '^' and $right ne '^' ) {
	    $new .= '^'
	} elsif ( $left ne '^' and $center ne '^' and $right eq '^' ) {
	    $new .= '^'
	} else {
	    $new .= '.';
	}
    }
    push @rows, $new;
}
for my $r ( @rows ) {
    for my $i ( split //, $r) {
	$safe_count +=1 if $i eq '.'
    }
}

say ">>> $safe_count";

44 lines [ Plain text ] [ ^Top ]

Day 18 - alternative solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/sum/;
#### INIT - load input data into array
my $part2 = shift || 0;
my $testing = 0;
my @input;
my $target = $testing? 10 : 40;
$target =  400_000 if $part2;
my $file = $testing ? 'test.txt' : 'input.txt';
{
    open( my $fh, '<', "$file" );
    while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
}

### CODE
# inspiration:
# https://www.reddit.com/r/adventofcode/comments/5iyp50/2016_day_18_solutions/dbcp5m0/
# don't load all data, just count 2 at a time

my $safe = 1;
my $trap = 0;
my $safe_count = 0;
my @row = ( $safe,
	    map  {$_ eq '^' ? $trap : $safe } (split //, $input[0]),
	    $safe );

$safe_count = sum( @row ) - 2;

for my $count ( 1 .. $target - 1 ) {
    my @new = (undef) x @row;
    $new[0] = $new[-1] = $safe;
    for ( my $i = 1; $i < @row -1 ; $i++ ) {
	$new[$i] //= ( $row[$i-1] xor $row[$i+1])? $trap : $safe ;
    }
    $safe_count = sum( @new ) - 2;
    @row = @new;
}
say ">>> $safe_count";

31 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 19

[ AoC problem link ] [ Discussion ].

Day 19 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my $no_of_elves = $testing ? 5 : 3005290;

### CODE

my @elves = ( 1 .. $no_of_elves );

while ( scalar @elves > 1 ) {
    my $taker = shift @elves;
    shift @elves;
    push @elves, $taker;
}

say ">>> ", join( '', @elves );

12 lines [ Plain text ] [ ^Top ]

Day 19 - part 2 (copied solution, see credit)


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my $no_of_elves = $testing ? 5 : 3005290;

### CODE
# Credit:
# https://www.reddit.com/r/adventofcode/comments/5j4lp1/2016_day_19_solutions/dbdgnwd/

my $winner = 1;
for ( my $i = 1 ; $i < $no_of_elves ; $i++ ) {
    $winner = $winner % $i + 1;
    if ( $winner > int( $i + 1 ) / 2 ) {
        $winner++;
    }
}

say ">>> $winner";

13 lines [ Plain text ] [ ^Top ]

Day 19 - part 2 (copied solution, see credit)


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my $no_of_elves = $testing ? 5 : 3005290;

### CODE
# Credit:
# https://www.reddit.com/r/adventofcode/comments/5j4lp1/2016_day_19_solutions/dbdnz4l/

# Divide the elves into left and right "halves", the right half being
# bigger if there's an odd number.
my @left = ( 1.. $no_of_elves / 2);
my @right= ( $no_of_elves/2 + 1 .. $no_of_elves );

while ( @left ) {
    # remove the giver
    shift @right;
    # keep the halves balanced
    if ( @right == @left ) {
	my $transfer = shift @right;
	push @left, $transfer;
    }
    # shift the taker to the end of the @right array
    my $taker = shift @left;
    push @right, $taker;
}

say ">>> ", join('',@right);

20 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 20

[ AoC problem link ] [ Discussion ].

Day 20 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use List::Util qw/max/;

#### INIT - load input data 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 $debug  = 0;
my $MAX_IP = 4294967295;

my @ranges;
for my $line (@input) {
    my ( $start, $end ) = $line =~ m/^(\d+)\-(\d+)$/;
    push @ranges, [ $start, $end ];
}

sub stringify {
    my ($n) = @_;
    die "can't stringify this giant number $n!" unless $n <= $MAX_IP;
    my @dotted = unpack 'C4', pack 'N', $n;
    return sprintf( "%10d (%3d.%3d.%3d.%3d)", $n, @dotted );
}

@ranges = sort { $a->[0] <=> $b->[0] } @ranges;

my $starting      = shift @ranges;
my $hwm           = $starting->[1];
my $allowed       = 0;
my $first_allowed = undef;
while (@ranges) {
    my $ending = shift @ranges;
    if ($debug) {
        say "  HWM: ", stringify($hwm);

        #        printf( "  HWM: %10s   %10d\n", '', $hwm );
        say "Start: ",
            stringify( $starting->[0] ), ' - ',
            stringify( $starting->[1] );
        say "  End: ",
            stringify( $ending->[0] ), ' - ',
            stringify( $ending->[1] );

    }
    if ( $debug and ( $starting->[1] >= $ending->[1] ) ) {
        printf( ">OVER: %10d < %10d (%d)\n",
                $ending->[1], $starting->[1], $starting->[1] - $ending->[1] );
    }

    if ( $ending->[0] - $hwm > 1 ) {
        if ( !defined $first_allowed ) {
            $first_allowed = $hwm + 1;
            say "1>> first not blocked: $first_allowed";
        }

        if ($debug) {
            say ">>GAP next highest: ", stringify( $ending->[0] );
            say "               HWM: ", stringify($hwm);
            say "              DIFF: ", $ending->[0] - $hwm;
        }
        $allowed += $ending->[0] - $hwm - 1;
    }
    my $this_max = max( @{$starting}, @{$ending} );
    $hwm = $this_max if ( $this_max > $hwm );
    $starting = $ending;
}
$allowed += $MAX_IP - $hwm;
say "2>> number of allowed: $allowed";

63 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 21

[ AoC problem link ] [ Discussion ].

Day 21 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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, $_; }
}

### SUBS 
sub rotate_right {
    my ( $ary, $offset, $no_of_rotations ) = @_;
    my @a = @{$ary};
    my @t = @a;
    for my $idx ( 0 .. $#t ) {
        $t[ ( $idx + $offset * $no_of_rotations ) % scalar @t ] = $a[$idx];
    }
    return \@t;
}

sub rotate_left {
    my ( $ary, $offset, $no_of_rotations ) = @_;
    my @a = @{$ary};
    my @t = @a;
    for my $idx ( 0 .. $#t ) {
        $t[ ( $idx - $offset * $no_of_rotations ) % scalar @t ] = $a[$idx];
    }
    return \@t;
}

sub move_pos {
    my ( $ary, $from, $to ) = @_;
    my @a = @{$ary};
    my $el = splice @a, $from, 1;
    splice @a, $to, 0, ($el);
    return \@a;
}

### CODE

my $starting = $testing ? 'abcde' : 'abcdefgh';
my @code = split( //, $starting );
my $debug = 0;

for my $line (@input) {
    if ( $line =~ m/^move position (\d+) to position (\d+)$/ ) {
        printf( "%36s: %s -> ", $line, join( '', @code ) ) if $debug;
        my $t = move_pos( \@code, $1, $2 );
        @code = @{$t};
        say @code if $debug;
    } elsif ( $line =~ m/^reverse positions (\d+) through (\d+)$/ ) {
        printf( "%36s: %s -> ", $line, join( '', @code ) ) if $debug;
	@code[$1..$2] = reverse @code[$1..$2];
        say @code if $debug;
    } elsif ( $line =~ m/^rotate based on position of letter (.)$/ ) {
        printf( "%36s: %s -> ", $line, join( '', @code ) ) if $debug;

        # find the position of the letter
        # http://www.perlmonks.org/?node_id=75660
        my ($idx) = grep { $code[$_] eq $1 } 0 .. $#code;
        my $no_of_rotations = 1 + $idx;

        if ( $idx >= 4 ) { $no_of_rotations++ }
        my $t = rotate_right( \@code, 1, $no_of_rotations );
        @code = @{$t};
        say @code if $debug;
    } elsif ( $line =~ m/^rotate (left|right) (\d+) steps?$/ ) {
        printf( "%36s: %s -> ", $line, join( '', @code ) ) if $debug;
        my $t;
        if ( $1 eq 'left' ) {
            $t = rotate_left( \@code, $2, 1 );
            @code = @{$t};
        } elsif ( $1 eq 'right' ) {
            $t = rotate_right( \@code, $2, 1 );
            @code = @{$t};
        }
        say @code if $debug;
    } elsif ( $line =~ m/^swap letter (.) with letter (.)$/ ) {
        printf( "%36s: %s -> ", $line, join( '', @code ) ) if $debug;
        my ($idx1) = grep { $code[$_] eq $1 } 0 .. $#code;
        my ($idx2) = grep { $code[$_] eq $2 } 0 .. $#code;
        my @tmp    = @code;
        $tmp[$idx1] = $code[$idx2];
        $tmp[$idx2] = $code[$idx1];
        @code       = @tmp;
        say @code if $debug;
    } elsif ( $line =~ m/^swap position (\d+) with position (\d+)$/ ) {
        printf( "%36s: %s -> ", $line, join( '', @code ) ) if $debug;
	@code[$2,$1] = @code[$1,$2];
        say @code if $debug;
    } else {
        die "can't parse line: $line";
    }
}
say join( '', @code );

87 lines [ Plain text ] [ ^Top ]

Day 21 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use Algorithm::Combinatorics qw(permutations);

#### INIT - load input data 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, $_; }
}

### SUBS
sub rotate_right {
    my ( $ary, $offset, $no_of_rotations ) = @_;
    my @a = @{$ary};
    my @t = @a;
    for my $idx ( 0 .. $#t ) {
        $t[ ( $idx + $offset * $no_of_rotations ) % scalar @t ] = $a[$idx];
    }
    return \@t;
}

sub rotate_left {
    my ( $ary, $offset, $no_of_rotations ) = @_;
    my @a = @{$ary};
    my @t = @a;
    for my $idx ( 0 .. $#t ) {
        $t[ ( $idx - $offset * $no_of_rotations ) % scalar @t ] = $a[$idx];
    }
    return \@t;
}

sub move_pos {
    my ( $ary, $from, $to ) = @_;
    my @a = @{$ary};
    my $el = splice @a, $from, 1;
    splice @a, $to, 0, ($el);
    return \@a;
}

### CODE
my $target = 'fbgdceah';
my @start  = sort split( //, $target );
my $iter   = permutations( \@start );
my $found  = 0;
my $count  = 0;
while ( my $c = $iter->next and !$found ) {
    my @code = @{$c};
    for my $line (@input) {
        if ( $line =~ m/^move position (\d+) to position (\d+)$/ ) {
            my $t = move_pos( \@code, $1, $2 );
            @code = @{$t};
        } elsif ( $line =~ m/^reverse positions (\d+) through (\d+)$/ ) {
            my @tmp = @code[ $1 .. $2 ];
            @tmp = reverse @tmp;
            my $count = 0;
            while (@tmp) {
                $code[ $1 + $count ] = shift @tmp;
                $count++;
            }
        } elsif ( $line =~ m/^rotate based on position of letter (.)$/ ) {

            # find the position of the letter
            # http://www.perlmonks.org/?node_id=75660
            my ($idx) = grep { $code[$_] eq $1 } 0 .. $#code;
            my $no_of_rotations = 1 + $idx;

            if ( $idx >= 4 ) { $no_of_rotations++ }
            my $t = rotate_right( \@code, 1, $no_of_rotations );
            @code = @{$t};
        } elsif ( $line =~ m/^rotate (left|right) (\d+) steps?$/ ) {
            my $t;
            if ( $1 eq 'left' ) {
                $t = rotate_left( \@code, $2, 1 );
                @code = @{$t};
            } elsif ( $1 eq 'right' ) {
                $t = rotate_right( \@code, $2, 1 );
                @code = @{$t};
            }
        } elsif ( $line =~ m/^swap letter (.) with letter (.)$/ ) {
            my ($idx1) = grep { $code[$_] eq $1 } 0 .. $#code;
            my ($idx2) = grep { $code[$_] eq $2 } 0 .. $#code;
            my @tmp    = @code;
            $tmp[$idx1] = $code[$idx2];
            $tmp[$idx2] = $code[$idx1];
            @code       = @tmp;
        } elsif ( $line =~ m/^swap position (\d+) with position (\d+)$/ ) {
            my @tmp = @code;
            $tmp[$1] = $code[$2];
            $tmp[$2] = $code[$1];
            @code    = @tmp;
        } else {
            die "can't parse line: $line";
        }
    }
    if ( join( '', @code ) eq $target ) {
        say '>> ', join( '', @{$c} );
        $found = 1;
    }
    $count++;
    if ( $count % 1000 == 0 ) {
        say $count, ' ', join( '', @{$c} );
    }
}

97 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 22

[ AoC problem link ] [ Discussion ].

Day 22 - part 1


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 @nodes;
for my $line (@input) {
    if ($line =~ m|node\-(x\d+\-y\d+)\s+(\d+)T\s+(\d+)T\s+(\d+)T\s+(\d+)\%$| )
    {
        my ( $id, $size, $used, $avail, $pct ) = ( $1, $2, $3, $4, $5 );
        my ( $x, $y ) = $id =~ m/^x(\d+)\-y(\d+)$/;
        push @nodes,
            { id    => $id,
              x     => $x,
              y     => $y,
              size  => $size,
              used  => $used,
              avail => $avail,
              pct   => $pct };
    }
}
my @pairs;
for my $node1 (@nodes) {
    for my $node2 (@nodes) {
        next if ( $node1->{id} eq $node2->{id} );
        next if ( $node1->{used} == 0 );
        if ( $node1->{used} <= $node2->{avail} ) {
            push @pairs, [ $node1, $node2 ];
        }
    }
}

say scalar @pairs;

37 lines [ Plain text ] [ ^Top ]

Day 22 - part 2


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $debug = 0;
my $nodes;
my ( $max_x, $max_y ) = ( 0, 0 );
for my $line (@input) {
    if ($line =~ m|node\-(x\d+\-y\d+)\s+(\d+)T\s+(\d+)T\s+(\d+)T\s+(\d+)\%$| )
    {
        my ( $id, $size, $used, $avail, $pct ) = ( $1, $2, $3, $4, $5 );
        my ( $x, $y ) = $id =~ m/^x(\d+)\-y(\d+)$/;
        if ( $x > $max_x ) { $max_x = $x }
        if ( $y > $max_y ) { $max_y = $y }
        $nodes->{$y}->{$x} = { id    => $id,
                               size  => $size,
                               used  => $used,
                               avail => $avail,
                               pct   => $pct };
    }
}
say "max_x $max_x max_y $max_y";
for my $x ( 0 .. $max_x ) {
    $nodes->{-1}->{$x} = { size => 10000 };
    $nodes->{ $max_y + 1 }->{$x} = { size => 10000 };
}
for my $y ( 0 .. $max_y ) {
    $nodes->{$y}->{-1} = { size => 10000 };
    $nodes->{$y}->{ $max_x + 1 } = { size => 10000 };
}

my $start;
# print the grid!
for my $y ( sort { $a <=> $b } keys %{$nodes} ) {
    next unless ( $y >= 0 and $y <= $max_y );
    for my $x ( sort { $a <=> $b } keys %{ $nodes->{$y} } ) {
        next unless ( $x >= 0 and $x <= $max_x );
        if ($debug) {
            printf( "%3d/%3d ",
                    map { $nodes->{$y}->{$x}->{$_} } qw/used size/ );
        } else {
            if ( $x == 0      and $y == 0 ) { print 'O'; next; }
            if ( $x == $max_x and $y == 0 ) { print 'G'; next; }
            if ( $nodes->{$y}->{$x}->{used} == 0 ) {
                $start->{x} = $x;
                $start->{y} = $y;
                print '_';
                next;
            }

            # can we transfer to neighbor?
	    # if not, it's a "wall"
            my $up    = $nodes->{ $y - 1 }->{$x}->{size};
            my $down  = $nodes->{ $y + 1 }->{$x}->{size};
            my $left  = $nodes->{$y}->{ $x - 1 }->{size};
            my $right = $nodes->{$y}->{ $x + 1 }->{size};
            my $used  = $nodes->{$y}->{$x}->{used};
            if (    $used > $up
                 or $used > $down
                 or $used > $left
                 or $used > $right )
            {
                print '#';
                next;
            } else {
                print '.';
            }
        }
    }
    print "\n";
}

printf( "Start: x=%d y=%d\n", $start->{x}, $start->{y} );

# Solution strategy:
# https://www.reddit.com/r/adventofcode/comments/5jor9q/2016_day_22_solutions/dbhvzaw/
#     move empty to 0,0: moves = start_x + start_y
# move empty to x_max,0: moves += x_max
# each move of goal data one step left is 5 moves,
# as the empty "cycles around": 
#                        moves += (x_max - 1)*5

say "Part 2: ", $start->{x} + $start->{y} + $max_x + ( $max_x - 1 ) * 5;

76 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 23

[ AoC problem link ] [ Discussion ].

Day 23 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data into array
my $testing = 0;
my $part    = 2;
my @input;
my $file = $testing ? 'test.txt' : 'input.txt';
{
    open( my $fh, '<', "$file" );
    while (<$fh>) { chomp; s/\r//gm; push @input, $_; }
}

### CODE
my $debug = 0;
my %reg = map { $_ => 0 } qw(a b c d);
$reg{a} = $part == 2 ? 12 : 7;

my @instr;
while (@input) {
    my ( $cmd, $arg1, $arg2 );
    my $line = shift @input;
    if ( $line =~ m/^(inc|dec) (.)$/ ) { push @instr, [ $1, $2, undef ] }
    elsif ( $line =~ /^cpy (\S+) (\S+)$/ ) { push @instr, [ 'cpy', $1, $2 ] }
    elsif ( $line =~ /^jnz (\S+) (-?\d+)$/ ) {
        push @instr, [ 'jnz', $1, $2 ];
    } elsif ( $line =~ /^jnz (\d+) (\S+)$/ ) {
        push @instr, [ 'jnz', $1, $2 ];
    } elsif ( $line =~ /^tgl (\S+)$/ ) {
        push @instr, [ 'tgl', $1, undef ];
    } else {
        die "cannot parse $line";
    }
}
my %freq;

sub dump_state {
    my ( $count, $pos, $cmd, $a1, $a2 ) = @_;
    printf( "%d cmd=[%s %s %s] => reg:[%d %d %d %d] next=%d\n",
            $count, $cmd, $a1,
            $a2 ? $a2 : '_',
            ( map { $reg{$_} } qw/a b c d/ ), $pos );
    $freq{$pos}++;
}

my $pos   = 0;
my $count = 0;
while ( $pos >= 0 and $pos <= $#instr ) {
    my ( $cmd, $a1, $a2 ) = @{ $instr[$pos] };
    $count++;
    warn "==> $count" if ( $debug and $count % 10_000 == 0 );
    if ( $cmd eq 'inc' ) {
        $reg{$a1} += 1;
        $pos++;
        dump_state( $count, $pos, $cmd, $a1, $a2 ) if $debug;
    } elsif ( $cmd eq 'dec' ) {
        $reg{$a1} -= 1;
        $pos++;
        dump_state( $count, $pos, $cmd, $a1, $a2 ) if $debug;
    } elsif ( $cmd eq 'cpy' ) {

        # can either copy integer or content of other register
        if   ( $a1 =~ /\d+/ ) { $reg{$a2} = $a1 }
        else                  { $reg{$a2} = $reg{$a1} }
        $pos++;
        dump_state( $count, $pos, $cmd, $a1, $a2 ) if $debug;
    } elsif ( $cmd eq 'jnz' ) {
        my $compare;
        if   ( $a1 =~ /\d+/ ) { $compare = $a1 }
        else                  { $compare = $reg{$a1} }
        my $jump;
        if   ( $a2 =~ /\d+/ ) { $jump = $a2 }
        else                  { $jump = $reg{$a2} }

        if ( $compare != 0 ) {
            $pos = $pos + $jump;
        } else {
            $pos++;
        }
        dump_state( $count, $pos, $cmd, $a1, $a2 ) if $debug;
    } elsif ( $cmd eq 'tgl' ) {
        my $newpos;
        if ( $a1 =~ /\d+/ ) { $newpos = $pos + $a1 }
        elsif ( $a1 =~ /[a-d]/ ) {
            $newpos = $pos + $reg{$a1};
        }
        if ( $newpos < 0 or $newpos > $#instr ) {

            # NOP
        } elsif ( $newpos == $pos ) {
            $pos++;
        } else {

            # do the toggle!
            if ( !defined( $instr[$newpos]->[2] ) ) {
                if ( $instr[$newpos]->[0] eq 'inc' ) {
                    $instr[$newpos]->[0] = 'dec';
                } else {
                    $instr[$newpos]->[0] = 'inc';
                }
            } elsif ( defined( $instr[$newpos]->[2] ) ) {
                if ( $instr[$newpos]->[0] eq 'jnz' ) {
                    $instr[$newpos]->[0] = 'cpy';
                } else {
                    $instr[$newpos]->[0] = 'jnz';
                }
            }
        }
        $pos++;
        dump_state( $count, $pos, $cmd, $a1, $a2 ) if $debug;
    }
}
say $reg{a};
if ($debug) {
    for my $p ( sort { $a <=> $b } keys %freq ) {
        say "$p: $freq{$p}";
    }
}

108 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 24

[ AoC problem link ] [ Discussion ].

Day 24 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;
use Algorithm::Combinatorics qw(permutations);

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

### CODE
my $maze;
my $targets;

sub find_shortest_path {
    my ( $start, $end ) = @_;
    my $seen;
    my $shortest = 0;
    my @states = ( [ 0, $start ] );
LOOP: {
        while (@states) {
            my $move = shift @states;
            my $step = $move->[0];
            my ( $r, $c ) = @{ $move->[1] };
            if ( exists $seen->{$r}->{$c} ) {
                next;
            } else {
                $seen->{$r}->{$c}++;
            }

            # try to move
            $step += 1;
            my @new = ( [ $r - 1, $c ],
                        [ $r + 1, $c ],
                        [ $r,     $c - 1 ],
                        [ $r,     $c + 1 ] );
            while (@new) {
                my $try = shift @new;
                my ( $t_r, $t_c ) = @{$try};
                if ( $maze->[$t_r]->[$t_c] ne '#' ) {
                    if ( $t_r == $end->[0] and $t_c == $end->[1] ) {
                        $shortest = $step;
                        last LOOP;
                    }
                    push @states, [ $step, $try ];
                }
            }
        }
    }
    return $shortest;
}

# load the maze
my $row = 0;
for my $line (@input) {
    my $col = 0;
    for my $cell ( split( //, $line ) ) {
        if ( $cell =~ /\d/ ) {
            $targets->{$cell} = [ $row, $col ];
        }
        $maze->[$row]->[$col] = $cell;
        $col++;
    }
    $row++;
}

# calculate distances using BFS
my $map;

for my $k ( sort keys %{$targets} ) {
    for my $j ( sort keys %{$targets} ) {
        next if $k == $j;
        $map->{$k}->{$j}
            = find_shortest_path( $targets->{$k}, $targets->{$j} );
    }
}

my @distances;

# always start at 0, so remove that for now
delete $targets->{0};
my $iter = permutations( [ keys %{$targets} ] );
while ( my $p = $iter->next ) {
    unshift @$p, '0';
    push @$p, '0' if $part2;
    my $dist = 0;
    for ( my $i = 0 ; $i < $#$p ; $i++ ) {
        my $j = $i + 1;
        $dist += $map->{ $p->[$i] }->{ $p->[$j] };
    }
    say "$dist: ", join( '-', @$p );
}

83 lines [ Plain text ] [ ^Top ]

Advent of Code 2016 day 25

[ AoC problem link ] [ Discussion ].

Day 25 - complete solution


#!/usr/bin/perl
use 5.016;    # implies strict, provides 'say'
use warnings;
use autodie;

#### INIT - load input data 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 $debug = 0;
my %reg = map { $_ => 0 } qw(a b c d);

my @instr;
while (@input) {
    my ( $cmd, $arg1, $arg2 );
    my $line = shift @input;
    if ( $line =~ m/^(inc|dec) (.)$/ ) { push @instr, [ $1, $2, undef ] }
    elsif ( $line =~ /^cpy (\S+) (\S+)$/ ) { push @instr, [ 'cpy', $1, $2 ] }
    elsif ( $line =~ /^jnz (\S+) (-?\d+)$/ ) {
        push @instr, [ 'jnz', $1, $2 ];
    } elsif ( $line =~ /^jnz (\d+) (\S+)$/ ) {
        push @instr, [ 'jnz', $1, $2 ];
    } elsif ( $line =~ /^tgl (\S+)$/ ) {
        push @instr, [ 'tgl', $1, undef ];
    } elsif ( $line =~ /^out (\S+)$/ ) {
        push @instr, [ 'out', $1, undef ];
    } else {
        die "cannot parse $line";
    }
}

my $in = 0;
LOOP: {
    for $in ( 0 .. 1000 ) {
        $reg{a} = $in;
        my $pos    = 0;
        my $count  = 0;
        my @output = ();
        warn "==> $in" if ( $debug and $in % 100 == 0 );
        while ( $pos >= 0 and $pos <= $#instr and scalar @output < 20 ) {
            my ( $cmd, $a1, $a2 ) = @{ $instr[$pos] };
            $count++;
            warn "==> $count" if ( $debug and $count % 10_000 == 0 );
            if ( $cmd eq 'inc' ) {
                $reg{$a1} += 1;
                $pos++;
            } elsif ( $cmd eq 'dec' ) {
                $reg{$a1} -= 1;
                $pos++;
            } elsif ( $cmd eq 'cpy' ) {

                # can either copy integer or content of other register
                if   ( $a1 =~ /\d+/ ) { $reg{$a2} = $a1 }
                else                  { $reg{$a2} = $reg{$a1} }
                $pos++;
            } elsif ( $cmd eq 'jnz' ) {
                my $compare;
                if   ( $a1 =~ /\d+/ ) { $compare = $a1 }
                else                  { $compare = $reg{$a1} }
                my $jump;
                if   ( $a2 =~ /\d+/ ) { $jump = $a2 }
                else                  { $jump = $reg{$a2} }

                if ( $compare != 0 ) {
                    $pos = $pos + $jump;
                } else {
                    $pos++;
                }
            } elsif ( $cmd eq 'tgl' ) {
                my $newpos;
                if ( $a1 =~ /\d+/ ) { $newpos = $pos + $a1 }
                elsif ( $a1 =~ /[a-d]/ ) {
                    $newpos = $pos + $reg{$a1};
                }
                if ( $newpos < 0 or $newpos > $#instr ) {

                    # NOP
                } elsif ( $newpos == $pos ) {
                    $pos++;
                } else {

                    # do the toggle!
                    if ( !defined( $instr[$newpos]->[2] ) ) {
                        if ( $instr[$newpos]->[0] eq 'inc' ) {
                            $instr[$newpos]->[0] = 'dec';
                        } else {
                            $instr[$newpos]->[0] = 'inc';
                        }
                    } elsif ( defined( $instr[$newpos]->[2] ) ) {
                        if ( $instr[$newpos]->[0] eq 'jnz' ) {
                            $instr[$newpos]->[0] = 'cpy';
                        } else {
                            $instr[$newpos]->[0] = 'jnz';
                        }
                    }
                }
                $pos++;
            } elsif ( $cmd eq 'out' ) {
                push @output, $reg{$a1};
                $pos++;
            }
        }

        if (    join( '', @output[ 0 .. 7 ] ) eq '01010101'
             or join( '', @output[ 1 .. 8 ] ) eq '01010101' )
        {
            say "$in: ", join( ' ', @output );
            last LOOP;
        }
    }
}


105 lines [ Plain text ] [ ^Top ]

Generated on Sun Dec 25 18:06:06 2016 UTC.