AOC - 2023
Advent of code solutions
Results and performance
The following are the results for (our) data sets – along with the timing for each script.
The total time is wall-clock time to run all (up to 25) scripts. The individual timings are based on the execution of the code (and disregard any code processing)
As of day 18 we have a running time of the first 19 scripts of around 11.5 seconds – which is an average time of 0.6 seconds per day.
txt
Part 1 Part 2 Time
Day 1 54159 53866 0.002464056
Day 2 2810 69110 0.001238823
Day 3 519444 74528807 0.003695011
Day 4 22674 5747443 0.003194094
Day 5 111627841 69323688 0.002525091
Day 6 741000 38220708 0.000060081
Day 7 251121738 251421071 0.008780003
Day 8 14257 16187743689077 0.031466961
Day 9 1806615041 1211 0.001220942
Day 10 6947 273 0.013419867
Day 11 9693756 717878258016 0.003212929
Day 12 7032 1493340882140 4.187124968
Day 13 34918 33054 0.167075872
Day 14 105461 102829 1.181010008
Day 15 521341 252782 0.008199930
Day 16 7623 8244 2.849364996
Day 17 954 1038 2.474735022
Day 18 40131 104454050898331 0.259993076
Day 19 397134 127517902575337 0.012871981
Running Total 11.211653711
Wall clock total 11.619670000
Day 1 - Trebuchet?!
Part 1
The score for each row is the first and last digit in the row – e.g. “1a2b3c4” gives 14. Required result is sum of scores.
Part 2
Digits can be written in English – e.g. “1a2boneight” gives 18. Required result is sum of scores
Solution
For both parts we use two reg to get the first and last value – last value we prefix with .* to match as much as possible before a match. In part 2 we just use a regex containing all the digits. and a hash to map back to 1..9.
day1.pl - perl
my %X;
@X{qw(one two three four five six seven eight nine)} = @X{1..9} = 1..9;
while(<>) {
$t1 += 10* $1 if /(\d)/;
$t1 += $1 if /.*(\d)/;
$t2 += 10* $X{$1} if /(\d|one|two|three|four|five|six|seven|eight|nine)/;
$t2 += $X{$1} if /.*(\d|one|two|three|four|five|six|seven|eight|nine)/;
}
Day 2 - Cube conundrum
Each row of input is a series of RGB counts of balls drawn from a bag e.g
3 blue, 4 red; 1 red, 2 green, 6 blue; 2 green
Part 1
We need to see if the data is consistent with there being 12 red, 13 green and 14 blue balls in the bag
We sum all the game numbers which are consistent
Part 2
This time we sum the product of the minimum number of different coloured balls in the bag.
day2.pl - perl
use List::Util qw(max);
my($t0,$t1,$t2)=(time,0,0);
while(<>) {
$t2 += ( my $r = max m{(\d+) red}g )
* ( my $b = max m{(\d+) blue}g )
* ( my $g = max m{(\d+) green}g );
$t1 += $1 if $r <= 12 && $g <= 13
&& $b <= 14 && m{(\d+)}
}
Day 3 - Gear ratios
Day 3 saw us with the first “map” question. We had two challenges
Part 1
We first have to find the numbers adjacent on the map to a symbol (u/d/l/r & diagonal)
Although initially solving part 1, we do some of the work for part 2 here by recording the information about the numbers in the grid – information we will use in part2 below.
Part 2
This time we have to find “*”s who have two neighbouring numbers and return the sum of the products of these numbers.
perl
my(@grid,@n) = grep { $_ } map { s{\s+$}{}r } <>; ## Tidy up grid...
## Part 1 - we are looking for symbols beside numbers - if there
## is one we include the number int eht title....
for my $r (0..$#grid) {
my($x, @p) = (0,split m{(\d+)}, $grid[$r]);
while(@p>1) {
$x += length shift @p;
my($S,$L) = ( $x ? $x-1 : 0, ( $x ? 2 : 1 ) + length $p[0] );
push @{$n[$r]}, [ $S, $S + $L - 1, $p[0] ];
$t1 += $p[0] if substr( $grid[$r ], $S, $L ) =~ m{[^\d.]}
|| $r>0 && substr( $grid[$r-1], $S, $L ) =~ m{[^\d.]}
|| $r<$#grid && substr( $grid[$r+1], $S, $L ) =~ m{[^\d.]};
$x += length shift @p;
}
}
## Part 2 - we now need to look for all stars and find neighbouring stars
$n[@grid]=[];
for my $r (0..$#grid) {
my($x,@p) = ( 0, split m{(\*)}, $grid[$r] );
while(@p>1) {
$x += length shift @p;
my($c,$z)=(0,1);
$_->[0] <= $x
&& $x <= $_->[1]
&& ( $z *= $_->[2] )
&& $c++
&& ( $t2 += $z )
&& last
for @{$n[$r-1]}, @{$n[$r]}, @{$n[$r+1]};
$x += length shift @p;
}
}
Day 4 - Scratchcards
You have a series of scratch cards – and the numbers drawn on the day for each card.
Part 1:
We need to compute the sum of scores – 1 match 1, 2 matches 2, 3 matches 4, 4 matches 8 etc…
We solve this by making one list a hash and then counting the number of entries seen in that hash…
Part 2:
Slightly harder… this time we have to count scratch cards.
If we have a card with “n” winning numbers – we win an extra copy of each of the next “n” cards. If we have say 3 of a card and that had 3 winners we would gain an extra 3 of the next three cards.
perl
my($i,@n)=(0);
for(<>) {
$n[0] ++;
my($l,$r,%x) = map { [split] } m{:\s+(.*)\s+\|\s+(.*)\s*$};
@x{@{$l}} = 1;
$n[$_] += $n[0] for 1..( my $t = grep{exists $x{$_}} @{$r} );
$t2 += shift @n;
$t1 += 1 << $t-1;
}
Day 5 - If You Give A Seed A Fertilizer
We start with a number of seeds in different locations.
We are then given a series of affine maps which translate the locations.
Each map consists of a list of regions (source,source+length-1) which gets mapped to (dest,dest+length-1).
Part 1:
We have to track the seeds through this map and find the lowest location at the end of the process…
Part 2:
This time the input represents ranges of numbers… This makes things slightly more challenging. We need to work with the ranges – but these overlap the affine mappings.
So at each point we have to break the region up into those parts which overlap different mapping regions. So the list of regions increases with each step.
perl
my (@l,$t,@r,$s,@m)=<>;
push @l, '';
my @v = my @n = (shift @l) =~ m{(\d+)}g;
push @r, [$s,$s+$t-1] while ($s,$t)=splice @n,0,2;
shift @l;
for(@l) {
unless( m{\S} ) {
@v = map { [ $t = $_, ## part 1
map { $t>=$_->[0] && $t<=$_->[1] ? $t+$_->[2] : () } @m
]->[-1] } @v;
for my $r ( @r ) { ## part 2
my( $st, @x ) = ( $r->[0]-1, [ $r->[1]+1, 0 ] );
push( @x, [ $_->[0] > $r->[0] ? $_->[0] : $r->[0],
$_->[1] > $r->[1] ? $r->[1] : $_->[1] ] ) &&
push( @n, [ $x[-1][0]+$_->[2], $x[-1][1]+$_->[2] ] )
for grep { $_->[0] <= $r->[1] && $r->[0] <= $_->[1] } @m;
push @n, map { ( $t, $st ) = ( $st + 1, $_->[1] );
$t < $_->[0] - 1 ? [ $t, $_->[0] - 1 ] : () }
sort { $a->[0] <=> $b->[0] } @x;
}
(@r,@m,@n) = @n;
}
## Add to map
push @m, [ $2, $2+$3-1, $1-$2 ] if m{(\d+) (\d+) (\d+)};
}
$t1 = shift @v ; $_ < $t1 && ($t1 = $_ ) for @v;
$t2 = [shift @r]->[0]; $_->[0] < $t2 && ($t2 = $_->[0]) for @r;
Day 6 - Wait For It
This is by far the easiest question. We can work out what value of $D is required to match the criteria.
We use the quadratic formulae to work out how many times we would beat the game.
In Part 1 we just multiply these together in Part 2 – we just need to compute the value
perl
my($T, $D ) = map { join '', @{$_} } my($t,$d) = map { [m{(\d+)}g] } <>;
($t1,$t2) = (1, $T - 1 - 2 * int( ($T - sqrt ($T*$T - 4*$D ))/2 ));
$t1 *= $_ - 1 - 2 * int 1/2*($_ - sqrt($_*$_ - 4*shift @{$d})) for @{$t};
Day 7 - Camel Cards
.
perl
my($c,$k) = (0,0);
my @in =
map {
my %f; $f{$_}++ for split //,$_->[0];
my $v = join '', reverse sort values %f;
my $j = delete $f{'b'}//0;
my @t = reverse sort values %f;
$t[0] += $j;
[ $_->[1], $_->[0], $v, join '', @t ]
}
map { $_->[0] =~ y/TJQKA/abcde/; $_ }
map { [m{(\w+)}g] } <>;
$t1 += $_->[0]*++$c for
sort { $a->[2] cmp $b->[2] || $a->[1] cmp $b->[1] }
@in;
$t2 += $_->[0]*++$k for
sort { $a->[3] cmp $b->[3] || $a->[1] cmp $b->[1] }
map { $_->[1]=~y/b/1/; $_ }
@in;
Day 8 - Haunted Wasteland
.
perl
use Math::Prime::Util qw(lcm);
my ($c,@i,@r,%x,@c,@e) = (0,map{ 'L'eq$_ ? 0 : 1 } <> =~ /([LR])/g );
my %r = map { m{(\w+).*?(\w+).*?(\w+)} ? ( $1 => [$2,$3] ) : () } <>;
my @K = keys %r;
@x{@K} = 0 .. $#K;
my $z = $x{'ZZZ'};
@r[ map{$x{$_}} @K ] = map { [ $x{$r{$_}[0]}, $x{$r{$_}[1]} ] } @K;
my @l = map { $x{$_} } grep { m{..A} } grep { m{..Z} ? $e[$x{$_}]=1 : 1 } keys %r;
unshift @i, pop @i;
@l = map { $e[ $_ = $r[$_][$i[$c%@i]] ]
? ( $z == $_ && ($t1=$c), push @c,$c ) && ()
: $_ } @l while ++$c && @l;
$t2 = lcm @c;
Day 9 - Mirage maintenance
.
perl
my($p,@C,@n) = (0,
1,-21,210,-1330,5985,-20349,54264,
-116280,203490,-293930,352716,-352716,
293930,-203490,116280,-54264,20349,
-5985,1330,-210,21,-1
);
for(<>) {
$n[$p++]+=$_ for split;
$p=0;
}
$t1 += $_*$C[$p++], $t2 -= $_*$C[$p] for @n;Day 10 - Pipe maze
.
perl
## Lookups....
my @O = ( [-1,0], [0,1], [1,0], [0,-1] );
my @D = (
{ '|' => 0, 'F' => 1, '7' => 3 },
{ 'J' => 0, '-' => 1, '7' => 2, },
{ 'L' => 1, '|' => 2, 'J' => 3 },
{ 'L' => 0, , 'F' => 2, '-' => 3 },
);
my @g = map { chomp; [ '.',(split//), '.'] } <>;
my (@b,$i,$j,$t,$u) = ('.')x@{$g[0]};
unshift @g, [ @b ];
push @g, [ @b ];
## Find start point...
O: for my $l ( 0..$#g ) {
$g[$l][$_] eq 'S' && ($t=$i=$l,$u=$j=$_) && last O for 0..$#{$g[0]};
}
## Find the pipe under the S and initial direction
$g[$i][$j]=[qw(. . . L . | F . . J - . 7 . . .)]->[
({'|'=>1,'7'=>1,'F'=>1}->{$g[$i-1][$j]}//0)+ # pipe above
({'-'=>2,'7'=>2,'J'=>2}->{$g[$i][$j+1]}//0)+ # pipe right
({'|'=>4,'L'=>4,'J'=>4}->{$g[$i+1][$j]}//0)+ # pipe below
({'-'=>8,'F'=>8,'L'=>8}->{$g[$i][$j-1]}//0)
]; # pipe left
my $d = exists $D[2]{$g[$i][$j]} ? 0 :
exists $D[3]{$g[$i][$j]} ? 1 : 2; ## Direction up, right, down
## We are going to make a map of the line.... Start with a blank map..
#my @g2 = map { [ @b ] } @g;
## Start we need to work out one of the directions...
## Keeping count of steps
do {
$i+=$O[$d][0],
$j+=$O[$d][1],
$t1++,
$d = $D[$d]{ $g[$i][$j] },
$g[$i][$j] =~ y/-7|JLF/123456/;
} until $t==$i && $u==$j;
## Now we count the numbers of cells inside the loop..
## To be inside - if you walk from left you have to have crossed
## the loop and odd number of times..
## If you see | or F---J or L---7 you cross the line;
## F---7 or L--J is NOT a crossing.
$i=0;
for ( @g ) {
## Remove horizontal pipes, split when pipe crosses line
$t2+= (++$i)&1 && length $_ for '',split /(?:64|52|3)/,
( join '', grep { $_ ne '1' } @{$_} )=~ s/(62|54)//gr;
}
$t1 /= 2; ## Mid point
Day 11 - Cosmic expansion
.
perl
my($E,$c,$k,@l,@p1,@p2,@p3,@p4) = (1_000_000,0,0,<>);
chomp @l;
my @v = map { [ $c += /#/?1:2, $k += /#/?1:$E ] } @l;
while( length $l[0] ) {
my( $f, $f2 ) = ( 2, $E );
substr($l[$_],0,1,'') eq '#' &&
( $f2=$f=1, (push @p1, $c),
(push @p2, $k),
(push @p3, $v[$_][0]),
(push @p4, $v[$_][1]) )
for 0..$#l;
$c += $f, $k += $f2;
}
$t1 = dsum(\@p1,\@p3);
$t2 = dsum(\@p2,\@p4);
sub dsum {
my($t,$c,@p) = (0,1,sort {$a<=>$b} @{$_[0]});
my @q = sort {$a<=>$b} @{$_[1]};
my $f = $p[0]+$q[0];
$t+= ($p[$_]+$q[$_]-$f)*$c*(@p-$c), $c++, $f=$p[$_]+$q[$_] for 1..$#p;
$t
}
Day 12 - Hot springs
.
perl
my%C;
while(<>){
my( $x, @c ) = m{^(\S+?) (\S+)} ? ($1,split/,/,$2) : (next); ## Parse string
$t1+=test( $x =~ /^\.*(.*?)\.*$/, @c ); ## Part 1
$t2+=test( "$x?$x?$x?$x?$x" =~ /^\.*(.*?)\.*$/, @c,@c,@c,@c,@c ); ## Part 2
}
sub test {
my( $v, $k, $x, $z, @c) = ( 0, "@_", @_ );
return $C{$k} if exists $C{$k}; ## Is is cached?
return $C{$k} = !$x || $x!~/#/ unless defined $z; ## Run out of blocks
## - true unless still have #
return $C{$k} = 0 unless $x; ## No string but parts to find
## Count no of '?'s we can start with, and compute regex to match
my $r = "^[?#]{$z}([.?][.]*(.*)|)\$";
## For each ?(0..n) we try to see if string starting with ? works
$x =~ /$r/ && ( $v += test( $2//'', @c ) ), substr $x,0,1,''
for 1 .. $x =~ /^([?]+)/ && length $1;
$C{$k} = $v + ( ## Finally cache & return.
$x =~ m{$r} ? test( $2//'', @c ) ## See if one starting with "#" works
: $x =~ s{^[.]+}{} && test( $s, $z, @c ) ) ## Strip trailing "." and try again
}
Day 13 - Point of incidence
.
perl
my(@l,$L);
my @in = <>; push @in, '';
for(@in) {
chomp;
$_ && ( push( @l, $_), next );
$L = -1 + length $l[0];
my ($v,$h) = score(0,0);
$t1 += $v*100+$h;
my(%vc,%hc);
Z: for my $z ( 0 .. $#l ) {
for my $x ( 0 .. $L ) {
my $t = substr $l[$z],$x,1; substr $l[$z],$x,1,$t eq '#' ? '.' : '#';
my($V,$H) = score($v,$h); substr $l[$z],$x,1,$t;
$t2 += 100*$V+$H, last Z if $V||$H;
}
}
@l=();
}
sub score {
my $vs = shift, my $hs = shift, my @r = map { scalar reverse $_ } @l;
my($vo,$ho)=(0,0);
O: for my $v (1..$#l) {
my $h = $v <= ($#l-$v) ? $v : $#l-$v+1;
($l[$_] eq $l[2*$v-$_-1]) || next O for ($v<=$#l/2 ? 0 : 2*$v-$#l-1) .. $v-1;
$vs == $v || ( $vo=$v, last );
}
P: for my $z ( 1 .. $L ) {
my $w = $z <= ($L-$z) ? $z : $L-$z+1;
my ($sl,$ch,$sr) = ( $z-$w, $w, $L-$z-$w+1 ); $sr = 0 if $sr<0;
substr( $l[$_], $sl,$w ) eq substr( $r[$_],$sr,$w ) || next P for 0..$#l;
$hs == $z || ( $ho=$z, last );
}
return ($vo,$ho);
}
Day 14 - Parabolic Reflector Dish
.
perl
my($t0,$t1,$t2)=(time,0,0);
## We wrap the map in "X"s as it avoids the issues of falling of the end...
my @map = map { chomp; $_='X'.$_.'X'; [split //] } <>;
my $rows = @map;
my $cols = @{$map[0]} - 2;
my( $TM, %CH, @SC ) = ( 1_000_000_000 );
unshift @map,[ ('X') x (2+$cols) ];
push @map,[ ('X') x (2+$cols) ];
for(0..999_999_999) {
## Tip N
for my $r (1..$rows) { for ( grep { $map[$r][$_] eq 'O' } 1..$cols ) {
my $j = $r; $j-- while( $map[$j-1][$_] eq '.');
$j==$r || (( $map[$r][$_],$map[$j][$_])=('.','O'));
} }
## First time round store result for part 1
unless($t1) { for my $c (1..$cols) {
$t1+=$rows+1-$_ for grep { $map[$_][$c] eq 'O' } 1..$rows;
} }
## Tip W
for my $c (1..$cols) { for ( grep { $map[$_][$c] eq 'O' } 1..$rows ) {
my $j = $c; $j-- while( $map[$_][$j-1] eq '.');
$j==$c || (( $map[$_][$c],$map[$_][$j])=('.','O'));
} }
## Tip S
for my $r (reverse 1..$rows) { for ( grep { $map[$r][$_] eq 'O' } 1..$cols ) {
my $j = $r; $j++ while( $map[$j+1][$_] eq '.');
$j==$r || (( $map[$r][$_], $map[$j][$_] ) = ('.','O'));
} }
## Tip E
for my $c (reverse 1..$cols) { for ( grep { $map[$_][$c] eq 'O' } 1..$rows ) {
my $j = $c; $j++ while( $map[$_][$j+1] eq '.');
$j==$c || (( $map[$_][$c],$map[$_][$j])=('.','O'));
} }
## Check for hit - if work out value for 1e9 entry...
## o/w cache...
my $K = join '', map{@$_} @map;
$t2 = $SC[ $CH{$K} + ( $TM - 1 - $_ ) % ( $_-$CH{$K} ) ], last if exists $CH{$K};
$CH{$K}=$_;
my $score = 0;
for my $c (1..$cols) {
$score+=$rows+1-$_ for grep { $map[$_][$c] eq 'O' } 1..$rows;
}
push @SC,$score;
}
##
## REGEX VERSION.....
##
$/=undef;
my $c = length [(my$M=<>)=~/(\S+)/]->[0];
my $r = int 1/($c+1)*(1 + length $M);
my( $U, $D, $f, $x, @S, %C ) =
( "[.](.{$c}(?:[.].{$c})*)O", "(.*)O(.{$c}(?:[.].{$c})*)[.]", $r );
1 while $M =~ s/$U/O$1./s; # Roll north
$t1+=$f--*y/O/O/ for split /\s+/, $M; # Compute score
for (1..1e9) {
1 while $M =~ s/([.]+)O/O$1/s; # Roll west
1 while $M =~ s/$D/$1.$2O/s; # Roll south
1 while $M =~ s/O([.]+)/$2O/s; # Roll east #V seen before?
$t2 = $S[ $C{$M} + (1e9-$_-1)%($_-$C{$M}) ], last if $C{$M};
($C{$M},$x,$f)=($_,0,$r); # Store time seen layout
$x+=$f--*y/O/O/ for split /\s+/, $M; # Compute score
push @S,$x; # & store
1 while $M =~ s/$U/O$1./s; # Roll north
}
Day 15 - Lens Library
.
perl
## We wrap the map in "X"s as it avoids the issues of falling of the end...
my @b = map { [] } 0..255;
my @e = map { chomp; split /,/ } <>;
O: for(@e) {
my($bn,$l,$o,$x) = (0,split /([-=])/);
$bn = 17*($bn+ord ) for split//,$l; ## Box number
$bn &= 255;
my $sc = 17*($bn+ord $o);
$sc = 17*($sc+ord ) for split//,$x//''; ## And score
$t1 += $sc&255; ## Part 1 here - Part 2 below
$b[$bn] = [ grep { $_->[0] ne $l } @{$b[$bn]} ], next if $o eq '-'; # delete
($_->[0] eq $l) && ($_->[1] = $x,next O) for @{$b[$bn]}; # replace
push @{$b[$bn]},[$l,$x]; # add
}
for my $x (0..255) {
$t2+=($x+1)*($_+1)*$b[$x][$_][1] for 0 .. $#{$b[$x]};
}
Day 16 - The Floor Will Be Lava
.
perl
## We wrap the map in "X"s as it avoids the issues of falling of the end...
#my @e = map { chomp; [ map { [ $_, 0, 0, 0, 0 ] } split // ] } <>;
# . => 1, | -> 2, - -> 3, / -> 4, \ -> 5
$/=undef;
$_=<>; chomp;
my @G = map {0+$_} split //, tr{-\r\n.|/\\}{3001245}r;
my @N = ( [], [[0],[1],[1 ],[2,8],[2],[8]], #1 ^
[[0],[2],[1,4],[2], [1],[4]], #2 >
[], [[0],[4],[ 4],[2,8],[8],[2]], #4 v
[], [], [], [[0],[8],[1,4],[ 8],[4],[1]] ); #8 <
s/\s.*//s;
my($H,$x) = @G/(my $W=1+length);
my @D = (0,-$W,1,0,$W,0,0,0,-1);
$x = score($_),$t1||=$x,$x>$t2 && ($t2=$x) for
map( { [$_*$W,2],[$_*$W+$W-2,8] } 0..$H-1 ),
map( { [$_, 4],[@G-2-$_, 1] } 0..$W-2 );
sub score {
my($sc,@b) = (0,shift);
my @z = map { 0 } @G;
while( @b ) {
my($p,$d) = @{pop @b};
next if $p<0 || $p>=$#G || !$G[$p] || $z[$p] & $d;
$z[$p]|=$d;
push @b, map { [ $p+$D[$_], $_ ] } @{$N[$d][$G[$p]]};
}
0 + grep { $_ } @z
}
Day 17 - Clumsy Crucible
.
perl
## Convert map into numeric array of weights..., get dimensions
my @g = map { chomp; [ map {0+$_} split // ] } <>;
my($H,$W) = ( scalar @g, scalar @{$g[0]} );
($t1,$t2) = ( solve( 0, 3 ), solve( 4, 10 ) );
printf "%16s %16s %15.9f\n", $t1, $t2, time-$t0;
sub solve {
my @B = map { [ map { 1e9 } @{$_} ] } @g; ## Caches of vertical/horizontal visits
my @C = map { [ map { 1e9 } @{$_} ] } @g; ## to locations - lowest loss to reach
($B[0][0],$C[0][0], my($min,$max,@Q)) = (0,0, @_,[ 0, 0, 0 ], [ 0, 0, 1 ] );
while( @Q && ( my($r,$c,$d) = @{shift @Q} ) ) {
if( $d ) {
my $t = my $v = $C[$r][$c]; ## We are now going to try horizontal moves
$v+=$g[$r][$c-$_],
($_ >= $min && $v < $B[$r][$c-$_]) &&
($B[$r][$c-$_]=$v, push @Q, [ $r, $c-$_, 0 ])
for 1 .. $max < $c ? $max : $c;
$t+=$g[$r][$c+$_],
($_ >= $min && $t < $B[$r][$c+$_]) &&
($B[$r][$c+$_]=$t, push @Q, [ $r, $c+$_, 0 ])
for 1 .. ($max < ($W-$c-1) ? $max : ($W-$c-1));
} else {
my $t = my $v = $B[$r][$c]; ## We are now going to try vertical moves
$v+=$g[$r-$_][$c],
($_ >= $min && $v < $C[$r-$_][$c]) &&
($C[$r-$_][$c]=$v, push @Q, [ $r-$_, $c, 1 ])
for 1 .. $max < $r ? $max : $r;
$t+=$g[$r+$_][$c],
($_ >= $min && $t < $C[$r+$_][$c]) &&
($C[$r+$_][$c]=$t, push @Q, [ $r+$_, $c, 1 ])
for 1 .. ($max < ($H-$r-1) ? $max : ($H-$r-1));
}
}
$B[-1][-1] < $C[-1][-1] ? $B[-1][-1] : $C[-1][-1]
}
Day 18 - Lavaduct Lagoon
.
perl
#!/usr/local/bin/perl
use strict;
use warnings;
use feature qw(say);
use Time::HiRes qw(time);
use Data::Dumper qw(Dumper);
my($t0,$t1,$t2)=(time,0,0);
my %M = qw(UU | UR F UD . UL 7 RU J RR - RD 7 RL .
DU . DR L DD | DL J LU L LR . LD F LL -);
## Convert map into numeric array of weights..., get dimensions
my @i = map { m{([RDUL]) (\d+) \(#([0-9a-f]{5})([0123])\)}
? [$1,$2,['R','D','L','U']->[$4],hex("0x$3")]
: () } <>;
my($min_r,$min_c)=my($max_r,$max_c)=my($r,$c)=(0,0);
my(%Rs,%Cs,$p);
## Part 1 ===========================================================
## Get bounds
for(@i) {
$c+=$_->[1]*( $_->[0] eq 'R' ? 1 : $_->[0] eq 'L' ? -1 : 0 );
$r+=$_->[1]*( $_->[0] eq 'D' ? 1 : $_->[0] eq 'U' ? -1 : 0 ); ## Move
$min_r = $r if $r < $min_r; $max_r = $r if $r > $max_r;
$min_c = $c if $c < $min_c; $max_c = $c if $c > $max_c; ## Check bounds
$t1 += $_->[1];
}
## Create empty grid
my @g = map { [ map { ' ' } 0 .. $max_c-$min_c ] } 0..$max_r-$min_r;
## Get start square {and previous direction - its a loop so last value}
($r,$c,$p)=(-$min_r,-$min_c,$i[-1][0]);
for my $i (@i) {
$g[ $r ][ $c ] = $M{ $p.$i->[0] }; ## Put previous turn symbol....
$g[ $r += $i->[0] eq 'D' ? 1 : $i->[0] eq 'U' ? -1 : 0 ]
[ $c += $i->[0] eq 'R' ? 1 : $i->[0] eq 'L' ? -1 : 0 ] =
$i->[0] eq 'R' || $i->[0] eq 'L' ? '-' : '|' for 1..$i->[1];
$p = $i->[0]
}
$g[$r][$c] = $M{$p.$i[0][0]};
## Now flood fill...
for (@g) {
my @parts = (join '',@{$_}) =~ s{(?:F-*7|L-*J)}{}gr
=~ m{(\s*)\S*}g; ## Remove F-7 & L-J don't cross
while(@parts) { ## each of these are whitespace - without/within...
shift @parts;
$t1+= length shift @parts if @parts
}
}
## Part 2 ===========================================================
## Get bounds & grid lines....
($min_r,$min_c)=($max_r,$max_c)=($r,$c)=(0,0);
for(@i) {
$Rs{ $c+=$_->[3]*( $_->[2] eq 'R' ? 1 : $_->[2] eq 'L' ? -1 : 0 ) } = 1;
$Cs{ $r+=$_->[3]*( $_->[2] eq 'D' ? 1 : $_->[2] eq 'U' ? -1 : 0 ) } = 1; ## Move
$min_r = $r if $r < $min_r; $max_r = $r if $r > $max_r;
$min_c = $c if $c < $min_c; $max_c = $c if $c > $max_c; ## check bounds
$t2 += $_->[3];
}
# Generate a series of block lengths - either containing a line s=e or a block s!=e
$p=-1;
my @gr = grep { $_->[1]>=$_->[0] }
map { [$p+1,$_-1,$_-$p-1], [$_,$p=$_,1] }
sort { $a<=>$b }
keys %Rs; ## Get "blocks" in order...
$p=-1;
my @gc = grep { $_->[1]>=$_->[0] }
map { [$p+1,$_-1,$_-$p-1], [$_,$p=$_,1] }
sort {$a<=>$b} keys %Cs;
@g = map { [ map { ' ' } @gc ] } @gr;
## Lets start by walking the grid....
($r,$c,$p)=( scalar grep( {$_->[0]<0} @gr ), scalar grep( {$_->[0]<0} @gc ), $i[-1][2] );
#exit;
for (@i) {
my($d,$x) = ($_->[2],$_->[3]);
$g[ $r ][ $c ] = $M{ $p.$d }; ## Put previous turn symbol....
if( $d eq 'R' ) { $x += $gc[$c][0]; $g[$r][++$c]='-' while $gc[$c][0]!=$x }
elsif( $d eq 'L' ) { $x = $gc[$c][0] - $x; $g[$r][--$c]='-' while $gc[$c][0]!=$x }
elsif( $d eq 'D' ) { $x += $gr[$r][0]; $g[++$r][$c]='|' while $gr[$r][0]!=$x }
elsif( $d eq 'U' ) { $x = $gr[$r][0] - $x; $g[--$r][$c]='|' while $gr[$r][0]!=$x }
$p = $d;
}
$g[ $r ][ $c ] = $M{ $p.$i[0][2] }; ## Put previous turn symbol....
## Now we fill the grid...
$r = 0;
for (@g) {
my $i = $c = 0;
$t2 += $gr[$r][2]*$gc[$c++][2]*('1'eq$_) for
split //, join '',
map { m{\S} ? ( ( m{(F-*7|L-*J)} || ($i=1-$i) ) x 0, $_ )
: ( $i ? '1' x length $_ : $_ ) }
split m{(\||[FL]-*[J7])}, join '', @{$_};
$r++;
}
Day 19 - Aplenty
Here we have a workflow processing system. We have objects with 4 ratings x,m,a,s.
And a series of “operations” which decide whether a piece is accepted or rejected, or passed onto another operations
rfg : s < 537 go to gd; x > 2440 reject; otherwise accept.
Part 1
The score is the sum of the product of all properties for items which are accepted;
It is a straight forward workflow following code. We start at the start point and apply the rules until we hit accept or reject;
Part 2
Now this is harder – we now have to work out how many items would be accepted if we tried items which have all combinations of values where x,m,a,s can lie between 1 and 4000.
You obviously can’t try all 256,000,000,000,000 combinations so we have to come up with a faster solution.
This is obviously a “range” solution. We start with a box which is 4000x4000x4000x4000. We then create a queue of “boxes” which we pass through the workflow. If we have a “<” or “>” operation we split the region in 2 {one which lies within the filter & one without) – the one within we push on the queue (if there is one) & the one without we check the next operator until we hit the “terminal operator with no “>”..
perl
my %wf; my @L =qw(x m a s);
while(<>) {
if( /^(\w*)\{(.*)\}/ ) {
my($key,@parts)=($1,split/,/,$2);
$wf{$key} = [ map { /(\w)([<>])(\d+):(\w+)/
? [ $4, $1, $2, $3 ] : [ $_, '', '', '' ]
} @parts ], next if $key;
my($x,%P) = ('in',map { split /=/, $_ } @parts);
while( 1 ) {
last if $x eq 'R';
map( { $t1+= $_ } values %P ), last if $x eq 'A';
for( @{$wf{$x}} ) {
$x = $_->[0], last if
$_->[1] eq '' ||
( $_->[2] eq '<' ? $P{$_->[1]} < $_->[3]
: $P{$_->[1]} > $_->[3] );
}
}
next;
}
my @b = ( { 'p' => 'in', map { $_ => [1,4000] } @L } );
while( @b ) {
my $x = shift @b;
if( $x->{'p'} eq 'A' ) {
my $v = 1; $v *= ($_->[1]-$_->[0]+1) for @{$x}{@L};
$t2 += $v;
} elsif( $x->{'p'} ne 'R' ) {
for ( @{$wf{$x->{'p'}}} ) {
my( $n, $k, $e, $v ) = @{$_};
my $t = { 'p' => $n, map { $_ => [ $x->{$_}[0], $x->{$_}[1] ] } @L };
if( $k eq '' ) {
push @b, $t;
} elsif( $e eq '<' ) { ## split below
if( $x->{$k}[1] < $v ) { ## we map all of the region;
push @b, $t;
} elsif( $x->{ $k }[0] < $v ) {
$x->{ $k }[0] = $v; $t->{ $k }[1] = $v-1; push @b, $t;
}
} else { ## split above
if( $x->{$k}[0] > $v ) { ## we map all of the region;
push @b, $t;
} elsif( $x->{ $k }[1] > $v ) {
$x->{ $k }[1] = $v; $t->{ $k }[0] = $v+1; push @b, $t;
}
}
}
}
}
}
Day 20 -
.
perl
.Day 21 -
.
perl
.Day 22 -
.
perl
.Day 23 -
.
perl
.Day 24 -
.
perl
.Day 25 -
.
perl
.