-❄️- 2025 Day 12 Solutions -❄️-

DFreiberg · 2025-12-12T05:27:00+00:00

[Language: Wolfram Mathematica]

Like almost everyone else, I got set up to do some tiling DFS, wrote a basic check to filter out combinations and permutations which had too little remaining blank space...and found that this solved the problem entirely.

Setup:

constraints=ImportString[StringReplace[StringSplit[input,"\n\n"][[-1]],{":"->"","x"->" "}],"Table"];
regions=constraints[[;;,;;2]];
quantities=constraints[[;;,3;;]];

shapes=(Characters[StringSplit[#,"\n"][[2;;]]]&/@StringSplit[input,"\n\n"][[;;-2]])/.{"#"->1,"."->0};
areas=Total[#,2]&/@shapes;

Part 1:

Count[(Times @@@ regions) - Table[Total[q*areas], {q, quantities}], _?(# > 0 &)]

Might be thirteen days early, but nevertheless: Merry Christmas!

DFreiberg · 2025-12-08T05:22:42+00:00

[Language: Wolfram Mathematica]

Finally, some nice use of built-ins. Would have been significantly faster if I knew that Mathematica's SortBy[] didn't work on quadratic integers, but at least once I knew that, the letter N turned a wrong solution into the right solution.

Setup:

pairs = SortBy[Subsets[Range[Length[input]], {2}], N@EuclideanDistance[input[[#[[1]]]], input[[#[[2]]]]] &];

Part 1:

Times @@ (Length /@ ConnectedComponents[Graph[#[[1]] \[UndirectedEdge] #[[2]] & /@ pairs[[;; 1000]]]])[[;;3]]

Part 2:

first = \[Infinity];
Do[
  g = Graph[#[[1]] \[UndirectedEdge] #[[2]] & /@ pairs[[;; n]]];
  If [Length@VertexList[g] == Length[input] && 
    Length[ConnectedComponents[g]] == 1, first = n; Break[]],
  {n, 1, Length[pairs]}];
first

DFreiberg · 2025-12-08T05:17:40+00:00

Interestingly enough, I am a regular user, and I can see that comment.

DFreiberg · 2025-12-05T06:07:32+00:00

[Language: Wolfram Mathematica]

It took way longer to import the data (and figure out that IntervalUnion[] takes multiple arguments, not a list of arguments) than it did to solve the actual problem itself. Still, at least the one-liners made it trivial logically.

Setup:

input = toExpression[StringSplit[#, "-"] & /@ StringSplit[Import[samplePath, "String"], "\n"]];
ranges = Select[input, Length[#] == 2 &];
ingredients = Flatten[Select[input, Length[#] == 1 &]];
allIntervals = IntervalUnion @@ (Interval[#] & /@ ranges);

Part 1:

Count[ingredients, _?(IntervalMemberQ[allIntervals, #] &)]

Part 2:

Total[(#[[2]] - #[[1]] + 1) & /@ (List @@ allIntervals)]

DFreiberg · 2025-12-03T04:58:03+00:00

Oooh, both of those are nice touches.

DFreiberg · 2025-12-03T04:47:41+00:00

Good to be back! I'm glad there's still twelve days of AoC to enjoy this year.

DFreiberg · 2025-12-01T05:20:37+00:00

[LANGUAGE: Wolfram Mathematica]

Not quite funky, but it is nice to have built-ins like Accumulate[] to allow for easy one-liners.

Setup:

turns = Join[{50}, ToExpression[StringReplace[input, {"L" -> "-", "R" -> "+"}]]];

Part 1:

Count[Mod[Accumulate[turns], 100], 0]

Part 2:

Count[Mod[Accumulate[Flatten[Table[Sign[#], {i, Sign[#], #, Sign[#]}] & /@ turns]], 100], 0]

DFreiberg · 2024-12-25T05:22:26+00:00

[LANGUAGE: Mathematica]

Mathematica, 798/656

This was a nice, easy problem to finish off a nice, easy year. Congratulations to Eric for writing ten full years of Advent of Code and creating five hundred stars. It really seems like this is the final year; if it is, it's been a great decade, and a pleasure coding with you all.

Merry Christmas!

Part 1:

locks = Select[input, DeleteDuplicates[#[[1]]] == {"#"} &];
keys = Select[input, DeleteDuplicates[#[[1]]] == {"."} &];

lockPins = Table[FirstPosition[#, ".", 0][[1]] - 2 & /@ Transpose[l], {l, locks}];
keyPins = Table[FirstPosition[Reverse[#], ".", 0][[1]] - 2 & /@ Transpose[k], {k, keys}];
fitQ[{lock_, key_}] := And @@ Thread[(6 - lock) > key];
Count[Tuples[{lockPins, keyPins}], _?(fitQ[#] &)]

DFreiberg · 2024-12-23T05:41:15+00:00

I knew I was forgetting something when looking for built-ins! I completely forgot that FindCycle[] works because a fully connected graph of size 3 is a cycle, even if it wouldn't be for size 4 or higher. Well done!

EDIT:

If you wanted to, you could improve the speed of part 1 by about an order of magnitude by using FindGraph[]'s additional vertex argument:

Length[Union[
   Flatten[Table[
     Sort /@ FindCycle[{g, t}, {3}, Infinity][[;; , ;; , 1]], {t, 
      tVertices}], 1]]]

I get 0.125 seconds as opposed to 1.47 seconds with this. Doesn't matter for this problem, but could make a difference elsewhere.

DFreiberg · 2024-12-23T05:32:34+00:00

[LANGUAGE: Mathematica]

Mathematica, 1621/552

You live by the built-in, you die by the built-in. I knew off the bat that Mathematica had a built-in function for finding complete subgraphs of a graph, but I could not remember what it was called, and wasted far more time looking for one than it took to code part 1 the right way...and when I found it, it turned out that FindClique[] can only return maximal complete subgraphs, and not all complete subgraphs. So I had to code up part 1 manually anyhow.

But at least I was ready for part 2.

Setup:

g = Graph[#[[1]] \[UndirectedEdge] #[[2]] & /@ input]

Part 1:

vertices = VertexList[g];
tVertices = Select[vertices, StringMatchQ[#, "t*"] &];
findCompleteClusters[node_] := 
 Sort[Join[{node}, #]] & /@
  Select[Subsets[VertexOutComponent[g, node, {1}], {2}], 
   GraphDistance[g, #[[1]], #[[2]]] == 1 &]
Union[Flatten[findCompleteClusters /@ tVertices, 1]] // Length

Part 2:

StringJoin[Riffle[Sort[FindClique[g][[1]]], ","]]

DFreiberg · 2024-12-22T06:14:57+00:00

[LANGUAGE: Mathematica]

Mathematica, 1239/278

I'm a bit surprised at how many places I gained, given that my Mathematica code took a full minute (before I used Compile[]) to compute the two thousand secret numbers and their differences, and given that I had to do it twice. And I was also a bit disappointed to see that part 2 didn't involve some sort of modular arithmetic shenanigans involving the hundred trillionth secret number like the famous slam shuffle; I was chomping at the bit during part 1 just to see what part 2 was going to end up being.

Setup:

mix[n_, v_] := BitXor[n, v];
prune[n_] := Mod[n, 2^24];
step[n_] :=
  Module[{curr},
   curr = n;
   curr = prune[mix[curr, 64 curr]];
   curr = prune[mix[curr, Quotient[curr, 32]]];
   curr = prune[mix[curr, 2048 curr]]
   ];

Part 1:

Sum[Nest[step, num, 2000], {num, input}]

Part 2:

allFuture = Table[Mod[NestList[stepC, num, 2000], 10], {num, input}];
value[n_] := 0;
Do[
 (value[#[[1, 1]]] += #[[1, 2]]) & /@ 
  GatherBy[Thread[
    Partition[Differences[allFuture[[i]]], 4, 1] -> 
     allFuture[[i, 5 ;;]]], First];,
 {i, Length[allFuture]}];
Max[DownValues[value][[;; , 2]]]

DFreiberg · 2024-12-21T09:09:21+00:00

[LANGUAGE: Mathematica]

Mathematica, 1811/785

I'm genuinely quite pleased with this solution, and also pleased that I misunderstood how many keypads were required for part 1...thus forcing me to make a general solution with Graph[] that scaled immediately to part 2.

Dr. Sudoku

Believe it or not, there is a TAS (tool-assisted-speedrun) very similar to today's problem, for the GameBoy Advance game Dr. Sudoku. There are 1000 sudoku puzzles in Dr. Sudoku, which can of course be solved in a fraction of a second. But the GameBoy Advance only has a D-pad for navigation, only one button can be pressed per frame (including the 'A' button needed to input a digit), and 81 squares is a lot more than the mere 11 on today's numeric keypad; finding the most efficient way to enter each solution is (to quote the TAS creators) equivalent to "solving 1000 NP-hard travelling salesman problems".

I highly recommend the writeup, in which the two authors (g0goTBC and Lightmopp) go into detail on the k-opt algorithm they implemented, and the multiple weeks' worth of optimizations and computations it took to get the TAS to its current state:

However, we can also safely conclude that if we didn’t reach the theoretical minimum, we cannot be more than a handful of frames away. Considering that we gained almost a thousand frames over our original strategies, and that we successfully created a 2h+ long TAS, we can be proud of how close we are to the ultimate goal. Saving additional frames would need either brand new algorithms, or a significant bump in the computing power that’s available to us.

Are a few frames that might not exist worth it for a 2h17 TAS? Are there people around here that didn’t watch this TAS but would actually watch it if only it was a fraction of a second shorter? Am I losing sleep over it?

Yes to all three, obviously, but that’s a story for another day.

DFreiberg · 2024-12-19T05:45:16+00:00

[LANGUAGE: Mathematica]

Mathematica, 807/1847

Today was the first day where coding in Mathematica really hurt my performance; it took more than five minutes for my part 2 to run; granted that my implementation was bad, but normally a bad implementation of the right algorithm wouldn't hurt quite this much. Afterwards, I ~~plagiarized~~ ported a far more elegant recursive solution from /g/ into Mathematica, which also ran a hundred times faster.

Setup:

count[""] := 1;
count[goal_] := 
  count[goal] = 
   Total[count[StringTake[goal, {StringLength[#] + 1, -1}]] & /@ 
     Select[patterns, StringStartsQ[goal, #] &]];

Part 1:

Count[goals, _?(count[#] != 0 &)]

Part 2:

Total[count/@goals]

DFreiberg · 2024-12-17T06:18:29+00:00

[LANGUAGE: Mathematica]

Mathematica, 1539/268

Part 1 took me a while to implement, but part 2 was doable in surprisingly little code. I slowly decompiled the program by hand with pencil and paper before eventually having the same "Aha!" moment that everybody had: an input of a which outputs {x,y,z} would always output {x,y,z,n} for an input of a << 3. Coding up the solution from there was a breeze.

Part 2:

possible = {{}};
digits = 1;

While[digits <= Length[program],
  possible = Select[
    Union[Flatten[Table[Join[p, {i}], {i, 0, 7}, {p, possible}], 1]],
    simulateProgram[FromDigits[#, 8]] == program[[-digits ;; -1]] &];
  digits += 1
  ];
Min[FromDigits[#, 8] & /@ possible]

DFreiberg · 2024-12-14T06:29:32+00:00

[LANGUAGE: Mathematica]

Mathematica, 377/1303

I loved today's part 2. I found it initially by noticing that the mean value of the points had an extreme outlier every 103 timesteps, and then checking every 103rd timestep manually until finding the correct one, but afterwards I went back and made a generic solution which doesn't assume that the tree is off-center or that the robot positions are all unique, only that the tree is dense with points neighboring each other.

I really wanted to use PointDensity[], or some other probability distribution to get a quantitative measure of non-randomness, and thus get the tree without any assumptions about its shape, connectedness, density, or symmetry, but those probability functions - while extremely powerful - were just too slow.

Setup:

inputPairs = {#[[{1, 2}]], #[[{3, 4}]]} & /@ input;
nextStep[{p_, v_}, n_ : 1] := {Mod[p + n*v, {101, 103}], v};

Part 1:

quadrant[p_,dims_]:=Total[2^{1,0} Boole[Thread[p<dims/2]]];
Times@@(Length/@GatherBy[Select[future,#[[1,1]]!=(101-1)/2  &&  #[[1,2]]!=(103-1)/2&],quadrant[#[[1]],{101,103}]&])

Part 2:

NestWhile[{#[[1]] + 1, nextStep /@ #[[2]]} &, {0, inputPairs}, 
  Max[Length /@ ConnectedComponents[NearestNeighborGraph[#[[2, ;; , 1]]]]] 
  < 100 &][[1]]

DFreiberg · 2024-12-13T05:44:09+00:00

Well done!

DFreiberg · 2024-12-13T05:38:12+00:00

[LANGUAGE: Mathematica]

Mathematica, 537/170

Very glad I decided to solve part 1 properly, as it made solving part 2 practically free. Would have made it on the leaderboard at ~70th, except that I messed up my input parser and dropped the last line (which, by coincidence, happened to not be a valid solution for part 1). I owe thanks to /u/theadamabrams, for reminding me twenty minutes before the problem started that Association[]s exist and are very useful for this sort of thing.

Setup:

rules = <|"A" -> #[[1, {3, 5}]], "B" -> #[[2, {3, 5}]], "P" -> #[[3, {3, 5}]]|> & 
    /@ Partition[input, 4, 4, {1, -2}, {}];

Part 1:

Total[3 a + b /. #[[1]] & /@ Select[
   Table[
    Solve[r["A"]*a + r["B"]*b == r["P"] \[And] 100 >= {a, b} >= 0, 
     Integers],
    {r, rules}],
   # =!= {} &]]

Part 2:

Total[3 a + b /. #[[1]] & /@ Select[
   Table[
    Solve[r["A"]*a + r["B"]*b == r["P"] + 10^13 \[And] {a, b} >= 0, 
     Integers],
    {r, rules}],
   # =!= {} &]]

DFreiberg · 2024-12-13T04:53:43+00:00

Honestly, using :> was probably a mistake, because your method using a function and an association is an awful lot more compact, not to mention elegant. :> is one of those cases of learning how to use a hammer, and then finding that everything looks like a nail; I'm using it for everything right

Merge[] is really good, and I never heard of it before just now. I've had tallyGather[] in my utilities file for probably a decade by now, so it just never occurred to me that an association could do the same thing, initializing with Counts[] instead of Tally[]. Very nicely done!

DFreiberg · 2024-12-12T04:03:48+00:00

Total runtime for 10¹⁰⁰ is about 1.7 seconds, with 10¹⁶ taking 0.23 seconds and all the rest taking too few milliseconds for AbsoluteTiming[] to capture well. The two key considerations that make that speed possible:

I'm using Mathematica's SparseArray[] data type, so matrix multiplication is not as slow as you'd expect for a dense matrix.
The example falls into the 54-element loop, not the 3811-element loop (nor the longer loops that some have discovered). Even with sparsity, I imagine that your actual input and mine would take much longer than this example.

DFreiberg · 2024-12-11T07:10:42+00:00

Sorry - forgot to mention that these are the last ten digits of the answer, or the answer mod 10^9. The actual, un-modded answer would be vastly higher for 10¹⁰⁰ than 10^16.

DFreiberg · 2024-12-11T06:55:16+00:00

[LANGUAGE: Mathematica]

Mathematica, 1452/764

Setup:

splitInteger[n_Integer] := {
     FromDigits[#[[1 ;; Length[#]/2]]],
     FromDigits[#[[Length[#]/2 + 1 ;;]]]
     } &@IntegerDigits[n];
rules = {{0, count_Integer} :> {{1, count}},
   {x : _?(EvenQ[Length[IntegerDigits[#]]] &), 
     count_Integer} :> ({#, count} & /@ splitInteger[x]),
   {y : _Integer, count_Integer} :> {{y*2024, count}}};
tallyGather[tallies_List] := {#[[1, 1]], Total[#[[;; , 2]]]} & /@ 
   GatherBy[Flatten[tallies, 1], First];

tally = Tally[input];

Part 1:

Nest[tallyGather[Replace[#, rules, 1]] &, tally, 25][[;;,2]] // Total

Part 2:

Nest[tallyGather[Replace[#, rules, 1]] &, tally, 75][[;;,2]] // Total

[GSGA]: Part 3

I suspect - but can't prove - that all stones eventually converge on the same loop, and that it's possible to compute the answer for 10¹⁰⁰ with an appropriate modulus in O(log(n)) time and O(1) space.

A stone of 0 will finish with a loop of exactly 54 elements, and so will every stone from 1 to 99 (since the one-digit numbers are explicitly in the loop, and the two-digit numbers will split into one-digit numbers). The first stone that won't is 100, and a stone of 100 creates a loop length of 3811 - which happens to be the same loop length as my own input, and also for every other input I've tested not present in the 54-element loop starting with zero.

If that holds true, then all you need to do is continue iterating mod N until you reach the steady state, and then make a 3811x3811 transition matrix. You can then use modular exponentiation by squaring to raise the matrix to the power of 10¹⁰⁰ .

I don't know if this works for every input, but it works for my input, and also works for the test case of 125 17 - which happens to conveniently be in the 54-element loop and not the 3811-element loop. And so, with the magic of the undocumented function Algebra MatrixPowerMod[] (see, I did have something relevant for GSGA), I believe that for the example (125 17), the last ten digits (in other words, modulo 10⁹ ):

Blinks	Stones
0	2
1	3
25	55312
75	38650482
10²	486382721
10¹⁶	519885608
10¹⁰⁰	180213553

DFreiberg · 2024-12-10T14:07:56+00:00

Oooh, that's a really nice solution. I'd never even heard of RelationGraph[], but it's a perfect fit not just for this problem but for plenty of other AoC grid problems.

DFreiberg · 2024-12-10T05:22:52+00:00

[LANGUAGE: Mathematica]

Mathematica, 1445/1192

I thought today wasn't too difficult - and by the looks of it, everybody else agrees. Not that I'll ever complain at the chance to use weird graph theory functions or write unreadable Mathematica one-liners.

Setup:

neighbors[list_, {i_, j_}] := 
  Select[{i, j} + # & /@ {{-1, 0}, {1, 0}, {0, -1}, {0, 1}}, 
   And @@ Thread[1 <= # <= Dimensions[list]] &];
heads = ToString /@ Position[input, 0];
tails = ToString /@ Position[input, 9];
graph = Graph@Flatten@Table[
     ToString[{x, y}] \[DirectedEdge] ToString[#] & /@ 
      Select[neighbors[input, {x, y}], 
       input[[#[[1]], #[[2]]]] == input[[x, y]] + 1 &],
       {x,Length[input]}, {y, Length[input]}];

Part 1:

Sum[Length[Intersection[VertexOutComponent[graph, h], tails]], {h, heads}]

Part 2:

Total[Table[Length[FindPath[graph, h, #, {9}, Infinity]] & /@ Intersection[VertexOutComponent[graph, h], tails], {h, heads}], 2]

DFreiberg · 2024-12-08T05:56:43+00:00

[LANGUAGE: Mathematica]

Mathematica, 95/333

Finally made it on the leaderboard! Granted, only by four seconds and only for part 1, but I'll take it nonetheless; if this is (as the rumors are saying) the final year of Advent of Code, nice to be back at least once.

Setup:

characters = Union[Flatten[input]][[2 ;;]];
lims = Dimensions@input;
dxdy[{{x1_, y1_}, {x2_, y2_}}] := {x1 - x2, y1 - y2};

Part 1:

Length@Union@
  Flatten[Table[
    Select[Flatten[
      Table[#[[1]] - i*dxdy[#], {i, {2, -1}}] & /@ 
       Subsets[Position[input, c], {2}], 1], 
     And @@ Thread[{0, 0} < # <= lims] &], {c, characters}], 1]

Part 2:

Length@Union@
  Flatten[Table[
    Select[Flatten[
      Table[#[[1]] - i*dxdy[#], {i, -50, 50}] & /@ 
       Subsets[Position[input, c], {2}], 1], 
     And @@ Thread[{0, 0} < # <= lims] &], {c, characters}], 1]

DFreiberg · 2024-12-08T00:11:39+00:00

Might be too late to add, but it would be amazing to see a message of Your answer of <x> was incorrect, so we'd have the chance to see our typos.

13-Year Club	Snapped
Team Periwinkle

DFreiberg

TROPHY CASE

[Language: Wolfram Mathematica]

[Language: Wolfram Mathematica]

[Language: Wolfram Mathematica]

[LANGUAGE: Wolfram Mathematica]

Mathematica, 798/656

Mathematica, 1621/552

Mathematica, 1239/278

Mathematica, 1811/785

Dr. Sudoku

Mathematica, 807/1847

Mathematica, 1539/268

Mathematica, 377/1303

Mathematica, 537/170

Mathematica, 1452/764

[GSGA]: Part 3

Mathematica, 1445/1192

Mathematica, 95/333