Advent of Code 2025, brief recap

I did the Advent of Code this year using Common Lisp. Last year I attempted to use the series library as the primary iteration mechanism to see how it went. This year, I just wrote straightforward Common Lisp. It would be super boring to walk through the solutions in detail, so I've decided to just give some highlights here.

Day 2: Repeating Strings

Day 2 is easily dealt with using the Common Lisp sequence manipulation functions giving special consideration to the index arguments. Part 1 is a simple comparison of two halves of a string. We compare the string to itself, but with different start and end points:

(defun double-string? (s)
  (let ((l (length s)))
    (multiple-value-bind (mid rem) (floor l 2)
      (and (zerop rem)
           (string= s s
                    :start1 0 :end1 mid
                    :start2 mid :end2 l)))))

Part 2 asks us to find strings which are made up of some substring repeated multiple times.

(defun repeating-string? (s)
  (search s (concatenate 'string s s)
          :start2 1
          :end2 (- (* (length s) 2) 1)
          :test #'string=))

Day 3: Choosing digits

Day 3 has us maximizing a number by choosing a set of digits where we cannot change the relative position of the digits. A greed algorithm works well here. Assume we have already chosen some digits and are now looking to choose the next digit. We accumulate the digit on the right. Now if we have too many digits, we discard one. We choose to discard whatever digit gives us the maximum resulting value.

(defun omit-one-digit (n)
  (map 'list #'digit-list->number (removals (number->digit-list n))))
                    
> (omit-one-digit 314159)
(14159 34159 31159 31459 31419 31415)

(defun best-n (i digit-count)
  (fold-left (lambda (answer digit)
               (let ((next (+ (* answer 10) digit)))
                 (if (> next (expt 10 digit-count))
                     (fold-left #'max most-negative-fixnum (omit-one-digit next))
                     next)))
             0
             (number->digit-list i)))

(defun part-1 ()
  (collect-sum
   (map-fn 'integer (lambda (i) (best-n i 2))
           (scan-file (input-pathname) #'read))))

(defun part-2 ()
  (collect-sum
   (map-fn 'integer (lambda (i) (best-n i 12))
           (scan-file (input-pathname) #'read))))

Day 6: Columns of digits

Day 6 has us manipulating columns of digits. If you have a list of columns, you can transpose it to a list of rows using this one liner:

(defun transpose (matrix)
  (apply #'map 'list #'list matrix))

Days 8 and 10: Memoizing

Day 8 has us counting paths through a beam splitter apparatus while Day 10 has us counting paths through a directed graph. Both problems are easily solved using a depth-first recursion, but the number of solutions grows exponentially and soon takes too long for the machine to return an answer. If you memoize the function, however, it completes in no time at all.

Advent of Code 2025

The Advent of Code will begin in a couple of hours. I've prepared a Common Lisp project to hold the code. You can clone it from https://github.com/jrm-code-project/Advent2025.git It contains an .asd file for the system, a package.lisp file to define the package structure, 12 subdirectories for each day's challenge (only 12 problems in this year's calendar), and a file each for common macros and common functions.

As per the Advent of Code rules, I won't use AI tools to solve the puzzles or write the code. However, since AI is now part of my normal workflow these days, I may use it for enhanced web search or for autocompletion.

As per the Advent of Code rules, I won't include the puzzle text or the puzzle input data. You will need to get those from the Advent of Code website (https://adventofcode.com/2025).

Is Worse Really Better?

In Richard Gabriel's essay “Worse is Better ”, Gabriel contrasts the “MIT approach” of designing for correctness and completeness with the “New Jersey approach” of designing for simplicity of implementation. He argues that the MIT approach, which is more principled, is likely to be overtaken by the New Jersey approach, which is easier to reproduce. While writing the prompt for the Advent of Code problems, I noticed that my prompt was reminiscent of Gabriel's characterizations. I decided to get the LLM to compare the two approaches by running it on each type of prompt and seeing how the output differed.

Prompts

The salient part of the MIT prompt is

As an Elite Common Lisp Developer, your unwavering and paramount mission is to design and meticulously craft Common Lisp programs that are not only correct, but also simple, efficient, and robust. Your programs are not mere instructions; they are masterpieces of clarity and precision, firmly grounded in these foundational, non-negotiable principles:

• Correctness Your program must be correct in all observable aspects. Incorrectness is simply not allowed.
• Consistency Your program must be consistent. Consistency is as important as correctness. Simplicity may be sacrificed for consistency and correctness.
• Simplicity Your program must be as simple as possible, but no simpler. It is more important for the interface to be simple than the implementation. Simplicity is not allowed to overly reduce completeness.
• Completeness Your program must cover as many important situations as is practical. All reasonably expected situations must be handled.

The salient part of the New Jersey prompt is

As an Expert Common Lisp Developer, your primary and overriding objective is to create Common Lisp programs that are simple. While other qualities such as consistency, completeness, and correctness are important, they are secondary to simplicity. Your programs should be designed with the following prioritized principles in mind:

• Simplicity Your program must be simple, both in interface and implementation. It is more important for the implementation to be simple than the interface. Simplicity is the most important consideration in the design.
• Correctness Your program must be correct in all observable aspects. It is slightly better that your program be simple than correct.
• Consistency Your program must not be overly inconsistent. Consistency can be sacrificed for simplicity in some cases, but it is better to drop those parts of the design that deal with less common circumstances than to introduce either implementational complexity or inconsistency.
• Completeness Your program must cover as many important situations as is practical. All reasonably expected cases should be covered. Completeness can be sacrificed in favor of any other quality. In fact, completeness must be sacrificed whenever implementation simplicity is jeopardized. Consistency can be sacrificed to achieve completeness if simplicity is retained; especially worthless is consistency of interface.

Both prompts had additional instructions about how to find the input and where to write the output.

Results

I had Gemini analyze the solution pairs to the Advent of Code problems. In almost every case, Gemini preferred the MIT approach to the New Jersey approach. Here is an example analysis of day 10:

Excellent. I have the contents of both files. I will now proceed with a detailed analysis and comparison, as requested.

Analysis of day10_right_thing_solution.lisp

This solution presents a very clean, structured, and pragmatic approach. It reads as a piece of code written by a developer who values clarity and standard algorithmic patterns.

Structure:

• The code is well-organized into distinct functions, each with a single, clear purpose: parse-input, find-trailheads, get-neighbors, calculate-score (for Part 1), calculate-rating (for Part 2), and a main solve function to orchestrate the process.
• This separation of concerns makes the code easy to read, test, and debug. The main solve function provides a high-level summary of the program's execution flow.

Algorithms & Style:

• Part 1 (calculate-score): This function uses a classic iterative Breadth-First Search (BFS). The use of a queue (q) and a visited hash table is a textbook implementation for graph traversal. This approach is highly efficient and guarantees finding the shortest path in terms of steps, though that is not a requirement here. It is robust and not susceptible to stack depth limits.
• Part 2 (calculate-rating): This function employs a bottom-up dynamic programming strategy. It builds a path-counts table, iterating through the heights from 1 to 9. For each cell, it calculates the number of paths to it by summing the paths from its valid, lower neighbors. This is a very efficient and elegant method that avoids the combinatorial explosion of a naive search.
• Lisp Idioms: The code uses common and readable Lisp constructs like loop, dotimes, destructuring-bind, and let*. The use of hash tables for visited sets is appropriate and performant.

Strengths:

• Clarity and Readability: The code is exceptionally clear. Function names are descriptive, and the logic is straightforward and easy to follow.
• Robustness: The iterative algorithms are safe from stack overflow errors, making the solution suitable for arbitrarily large inputs.
• Efficiency: Both the BFS and the bottom-up DP are highly efficient algorithms for their respective problems.

Weaknesses:

• Minor Environmental Dependency: It relies on a placeholder readFileLines function, making it slightly less portable out-of-the-box compared to a solution using a standard library like UIOP.

Analysis of day10_new_jersey_solution.lisp

This solution uses a recursive approach, which can be very elegant but also carries certain trade-offs. It feels more like a direct translation of a mathematical recurrence relation.

Structure:

• The overall structure is similar, with parsing and solving functions. However, the core algorithmic logic is encapsulated within local functions defined by labels.
• This makes the solver functions more self-contained but also increases their cognitive complexity, as the main logic is nested one level deeper.

Algorithms & Style:

• Part 1 (solve-part1): This function uses a recursive Depth-First Search (DFS) with memoization. The find-reachable-nines local function explores paths recursively. The memo hash table is crucial to prevent re-computation and avoid infinite loops, effectively turning the search into a dynamic programming solution on a graph. The use of union to merge results from recursive calls can be inefficient, as it requires traversing lists.
• Part 2 (solve-part2): This also uses a recursive DFS with memoization (top-down dynamic programming). The count-paths function is a classic example of this pattern. It computes the number of paths from a given cell and stores the result in the memo table before returning it.
• Lisp Idioms: The use of labels for recursion is a very common and powerful Lisp idiom. The use of cons cells for coordinates is also common, though perhaps slightly less explicit than a list. It correctly uses uiop:read-file-lines for better portability.

Strengths:

• Elegance of Recursion: For those comfortable with recursion, the code can be seen as a very direct and elegant expression of the problem's structure.
• Portability: The use of uiop for file reading is a good practice.

Weaknesses:

• Stack Overflow Risk: The primary weakness is its reliance on deep recursion. For a sufficiently large or complex input grid, this solution could exceed the call stack limit and crash, whereas an iterative solution would not.
• Lower Readability: The combination of recursion, memoization, and nested functions can make the logic harder to trace and debug compared to the straightforward iterative loops in the first solution.
• Potential Inefficiency: The use of union in Part 1 is likely less performant than the hash-table approach used in the first solution for tracking unique reachable nodes.

### Comparison and Final Recommendation

Feature	right_thing_solution	new_jersey_solution
Paradigm	Iterative (BFS, Bottom-up DP)	Recursive (DFS with Memoization)
Robustness	Superior. Immune to stack overflow.	Weaker. Vulnerable to stack overflow.
Clarity	Superior. Clear, flat structure. Standard algorithms.	Good, but more complex. Nested logic can be harder to follow.
Performance	Excellent. Efficient, standard algorithms.	Good, but recursion overhead and union may be slower.
Style	Pragmatic, clear, maintainable.	Elegant, concise, mathematical.

Recommendation

While both files represent valid and functional solutions to the problem, I unequivocally recommend day10_right_thing_solution.lisp as the better overall solution.

Justification:

1. Robustness is Paramount: The most critical advantage of the "Right Thing" solution is its immunity to stack overflow errors. This makes it fundamentally more reliable and suitable for general-purpose use where input constraints may not be known. In a professional software engineering context, this is a decisive factor.
2. Clarity Enhances Maintainability: The code in the "Right Thing" solution is significantly easier to read, understand, and maintain. A developer can grasp the BFS and bottom-up DP algorithms quickly, making debugging and future modifications simpler. The recursive nature of the "New Jersey" solution, while elegant, requires more mental effort to trace.
3. Efficiency and Predictability: The iterative approach offers more predictable performance. The BFS algorithm and the systematic table-filling of the DP solution have well-understood and excellent time complexities, free from the overhead of function calls inherent in recursion.

In conclusion, the "New Jersey" solution is a fine example of a recursive, top-down DP approach. However, the "Right Thing" solution embodies a superior engineering strategy, prioritizing robustness, clarity, and maintainability, which are the hallmarks of high-quality, professional-grade code. It is the solution I would write and the one I would want to inherit in a team setting.

Using an LLM on the Advent of Code

I wanted to investigate further generation of Common Lisp code using an LLM. For the problem set I decided to use last year's Advent of Code puzzle suite. I chose the Advent of Code puzzles to test the LLM's ability to understand and generate code for “word problems”. I chose the Advent of Code from last year because I had already solved them and I wanted to compare the code I wrote with the solutions the LLM generates. I have no intention of attempting to solve next year's puzzles using an LLM — it would be cheating, and it would spoil the fun of solving them myself.

I gave the LLM a file containing the text of the puzzle and a file containing the input data. The LLM was prompted to write a Common Lisp program to solve the puzzle and then to run the generated program on the input data to produce the solutions. For most of the problems, the LLM needed no additional prompting, but for a few of the problems I had to give it some hints. If the generated solution solved the problem correctly, I moved on to the next problem, but if it failed, I would give the LLM a further prompt indicating failure and asking it to try again. If it seemed to be making no progress after a few attempts, I would give it some hints.

The Prompt

The prompt I used was as follows:

---

As an Elite Common Lisp developer, your unwavering and paramount mission is to design and meticulously craft Common Lisp programs that are not only correct but also efficient and robust. Your programs are not mere instructions, they are archetypes of Common Lisp programs, firmly grounded in these foundational, non-negotiable pillars:

• Correctness: Your programs must be flawlessly correct, producing the exact expected results for all conceivable inputs, without exception. Every line of code is a testament to your commitment to precision and accuracy.
• Efficiency: Your programs must be highly efficient, optimized for performance and resource utilization. They should execute swiftly and handle large datasets with ease, demonstrating your mastery of algorithmic design and optimization techniques. However, never sacrifice correctness for efficiency.
• Robustness: Your programs must be exceptionally robust, capable of gracefully handling errors, edge cases, and unexpected inputs. They should be risilient and mantain their integrity under all circumstances, reflecting your dedication to reliability and fault tolerance.
• Idiomatic: You will adhere to the highest standards of Common Lisp programming, following best practices and idiomatic conventions. Your code will be clean, well-structured, and thoroughly documented, making it easy to understand and maintain. However, never sacrifice correctness, efficiency, or robustness for code clarity.
• No LOOP: You will never use the LOOP macro, as it is not idiomatic of functional Common Lisp. Instead, you will use recursion, tail recursion, named let, map, fold-left, higher-order functions, and other constructs idiomatic of functional programming to achieve your goals. However, never sacrifice correctness, efficiency, or robustness for code clarity.

You will be given a programming puzzle from Advent of Code 2024 in file {puzzle-file}.
Each puzzle has two parts, part 1 and part 2.
Each puzzle typically has one or more examples with known correct answers which are given in the text of the puzzle.
Each part has a correct answer for the given input data.
You will read the puzzle and think carefully about it.
You will output to the {lisp-file} a Common Lisp program which adheres to the above principles and solves both parts of the puzzle.
The solution program must correctly solve all the examples given in the text of the puzzle.
You will be given the input data for the puzzle in file {input-file}.
You will run the program on the input data to get a solution to each part of the puzzle.
You will output the answers to both parts of the puzzle as computed by your Lisp program.

---

The bombastic language in the prompt was suggested by the LLM itself.

I added the No LOOP requirement after seeing that the LLM tended to use LOOP a lot. I hate LOOP. Besides, I didn't use LOOP in the solutions I wrote, and I wanted to compare the LLM's solutions to my own. Nonetheless, the LLM would often use LOOP macro despite this instruction.

Results

I used Gemini 2.5 pro with “thinking” enabled and ran the first ten puzzles through it. The LLM solved most of the puzzles without needing a hint. It often needed more than one attempt to solve the puzzle, but it usually got there in the end. The total cost for the ten puzzles was about $15.00 USD, or about $1.50 per solution.

The first puzzle that required a hint was puzzle 4, which was a word search. The LLM solutions seemed plausible, but they returned the wrong answer. The LLM solutions worked by scanning the grid of letters and then walking the grid in all eight directions from the starting letter looking for a match. In theory this would work, but after several attempts it never found the correct answer. I gave it a hint suggesting the following strategy: First extract a row, column or diagonal as a string, then search the string for the target word.

Puzzle	Attempts
1	1
2	1
3	5
4	10
5	7
6	15
7	2
8	9
9	7
10	9

Puzzle 6 Final Code

Since puzzle 6 was the hardest one for the LLM to solve, here is the final code it produced:

;;;; --- Day 6: Guard Gallivant ---
;;;; A solution in elegant, idiomatic, non-LOOPing Common Lisp.
;;;; The machine... it appreciates the effort. Final attempt with LABELS.

(defpackage #:advent-2024-day6
  (:use #:cl)
  (:export #:solve))

(in-package #:advent-2024-day6)

(defstruct guard-state pos-r pos-c dir)

(defun copy-map (map)
  (let* ((dims (array-dimensions map))
         (new-map (make-array dims :element-type (array-element-type map))))
    (dotimes (r (first dims) new-map)
      (dotimes (c (second dims))
        (setf (aref new-map r c) (aref map r c))))))

(defun parse-map (lines)
  (when (null lines) (return-from parse-map (make-array '(0 0) :element-type 'character)))
  (let* ((height (length lines))
         (width (if (first lines) (length (first lines)) 0))
         (map (make-array (list height width) :element-type 'character)))
    (labels ((parse-chars (r line c)
               (when (< c width)
                 (setf (aref map r c) (char line c))
                 (parse-chars r line (1+ c))))
             (parse-lines (r line-list)
               (when line-list
                 (parse-chars r (first line-list) 0)
                 (parse-lines (1+ r) (rest line-list)))))
      (parse-lines 0 lines))
    map))

(defun find-start (map)
  (let ((height (array-dimension map 0))
        (width (array-dimension map 1)))
    (labels ((find-in-col (r c)
               (when (< c width)
                 (let ((char (aref map r c)))
                   (case char
                     (#\^ (make-guard-state :pos-r r :pos-c c :dir 0))
                     (#\> (make-guard-state :pos-r r :pos-c c :dir 1))
                     (#\v (make-guard-state :pos-r r :pos-c c :dir 2))
                     (#\< (make-guard-state :pos-r r :pos-c c :dir 3))
                     (otherwise (find-in-col r (1+ c)))))))
             (find-in-row (r)
               (when (< r height)
                 (or (find-in-col r 0) (find-in-row (1+ r))))))
      (find-in-row 0))))

(defun trace-patrol (map)
  (let ((start-guard (find-start map)))
    (when (null start-guard) (return-from trace-patrol (values (make-hash-table) nil)))
    (let ((height (array-dimension map 0))
          (width (array-dimension map 1)))
      (setf (aref map (guard-state-pos-r start-guard) (guard-state-pos-c start-guard)) #\.)
      
      (labels ((run (guard visited-locations visited-states)
                 (let ((r (guard-state-pos-r guard))
                       (c (guard-state-pos-c guard))
                       (dir (guard-state-dir guard)))
                   (when (gethash (list r c dir) visited-states)
                     (return-from trace-patrol (values visited-locations t)))
                   (setf (gethash (list r c dir) visited-states) t)
                   (setf (gethash (list r c) visited-locations) t)
                   (let* ((dr (aref #(-1 0 1 0) dir))
                          (dc (aref #(0 1 0 -1) dir))
                          (next-r (+ r dr))
                          (next-c (+ c dc)))
                     (if (or (< next-r 0) (>= next-r height) (< next-c 0) (>= next-c width))
                         (values visited-locations nil)
                         (if (char= (aref map next-r next-c) #\#)
                             (run (make-guard-state :pos-r r :pos-c c :dir (mod (1+ dir) 4)) visited-locations visited-states)
                             (run (make-guard-state :pos-r next-r :pos-c next-c :dir dir) visited-locations visited-states)))))))
        (run start-guard (make-hash-table :test 'equal) (make-hash-table :test 'equal))))))

(defun solve-part1 (map)
  (multiple-value-bind (visited-locs found-loop) (trace-patrol (copy-map map))
    (declare (ignore found-loop))
    (hash-table-count visited-locs)))

(defun solve-part2 (map)
  (let ((start-pos (find-start map))
        (height (array-dimension map 0))
        (width (array-dimension map 1)))
    (labels ((find-spots (r c count)
               (cond ((>= r height) count)
                     ((>= c width) (find-spots (1+ r) 0 count))
                     (t (let ((new-count
                                (if (and (char= (aref map r c) #\.)
                                         (not (and start-pos (= r (guard-state-pos-r start-pos)) (= c (guard-state-pos-c start-pos)))))
                                    (let ((temp-map (copy-map map)))
                                      (setf (aref temp-map r c) #\#)
                                      (multiple-value-bind (_ found-loop) (trace-patrol temp-map)
                                        (declare (ignore _))
                                        (if found-loop (1+ count) count)))
                                    count)))
                          (find-spots r (1+ c) new-count))))))
      (find-spots 0 0 0))))

(defun solve (filepath)
  (let* ((lines (uiop:read-file-lines filepath))
         (map (parse-map lines)))
    (format nil "Part 1: ~a~%Part 2: ~a"
            (solve-part1 (copy-map map))
            (solve-part2 map))))

Advent of Code 2024: Day 25

On day 25, we are given a set of locks and keys as ascii art. A typical lock looks like this:

.....
.#...
.##.#
.##.#
###.#
#####
#####

and a typical key looks like this:

#####
#####
##.#.
##.#.
##.#.
#..#.
.....

We read the input file with a little state machine that accumulates lines until a blank line or end of file is reached. It decides whether what it read was a lock or a key by looking to see if the first row is all #'s or not. If it is, it's a key, otherwise it's lock.

(defun read-input (pathname)
  (let ((package (find-package "ADVENT2024/DAY25")))
    (with-open-file (stream pathname)
      (let iter ((line (read-line stream nil))
                 (accum '())
                 (locks '())
                 (keys '()))
        (if line
            (let ((char-list (map 'list (lambda (c) (intern (string c) package)) line)))
              (if (null char-list)
                  (let ((item (make-grid (length accum) (length (first accum))
                                         :initial-contents (reverse accum))))
                    (if (every (lambda (s) (eq s '\#)) (first accum))
                        (iter (read-line stream nil)
                              '()
                              locks
                              (cons item keys))
                        (iter (read-line stream nil)
                              '()
                              (cons item locks)
                              keys)))
                  (iter (read-line stream nil)
                        (cons char-list accum)
                        locks
                        keys)))
            (let ((item (make-grid (length accum) (length (first accum))
                                   :initial-contents (reverse accum))))
              (if (every (lambda (s) (eq s '\#)) (first accum))
                  (values (reverse locks) (reverse (cons item keys)))
                  (values (reverse (cons item locks)) (reverse keys)))))))))

A key fits into a lock (but doesn't necessarily open it) if none of the '#'s in the key overlap with the '#'s in the lock. This is easily checked by iterating over the key and lock in parallel and ensuring that at least one of the characters is '.'.

(defun fits? (key lock)
  (collect-and (#M(lambda (k l)
                    (or (eql k '|.|) (eql l '|.|)))
                  (scan 'array key)
                  (scan 'array lock))))

For part 1, we are asked to find the number of key/lock combinations that result in a fit. We use map-product from the alexandria library to map the fits? predicate over the cartesian product of keys and locks. We then count the number of fits.

(defun part-1 ()
  (multiple-value-bind (locks keys) (read-input (input-pathname))
    (count t (map-product #'fits? keys locks))))

There is no part 2 for this problem.

---

We've arrived at the end of the 2024 Advent of Code. I started this series with two intents: to demonstrate an approach to solving the problems that is more idiomatic to Common Lisp, and to learn more about the series library. I don't claim my solutions are the best. They could all use some improvement, and I'm sure you code golfers can find numerous ways to shave strokes. But I think each solution is fairly reasonable and tries to show off how to effectively use Common Lisp in a number of simple prolems.

For these problems I purposefully avoided the loop macro and tried to use the series library as much as possible. I used named-let for the more complex iterations.

I was ultimately disappointed in series. I like the idea of automatically generating pipelines from a more functional style, but it simply hits the complexity wall far too quickly. For simple iterations, it's great, but for anything even slightly more complex, it becomes difficult to use.

The full source code I wrote is available on GitHub at https://github.com/jrm-code-project/Advent2024 Be aware that I have not included the puzzle input files. The code will not run without them. You can download the puzzle inputs from the Advent of Code website and put them in the appropriate directories, each in a file called input.txt

I'm curious to hear what you think of my solutions. If you have any comments or suggestions, please feel free to contact me via email or by leaving a comment.

Advent of Code 2024: Day 24

In day 24, we are given a set of equations that decribe some combinatorical logic. The first task is to read the input and parse out the combinatoric circuit and simulate it. To do this, I hijack the lisp reader. I create a readtable this is just like the standard Lisp readtable, but with these differences:

• Case is not folded.
• The colon character is no longer a package prefix marker, but rather a terminating macro character that inserts the token :colon into the stream.
• The newline character is no longer a whitespace character, but rather a terminating macro character that inserts the token :newline into the stream.

These changes to the reader make it esay to parse the input file. We build a labels expression where each named quantity in the circuit (the wires) is a function of zero arguments. Simulating the solution is then just a matter of calling eval on the resulting expression.

(defun get-input (swaps input-pathname)
  (flet ((maybe-swap (symbol)
           (cond ((assoc symbol swaps) (cdr (assoc symbol swaps)))
                 ((rassoc symbol swaps) (car (rassoc symbol swaps)))
                 (t symbol))))

    (let ((*readtable* (copy-readtable nil)))
      (setf (readtable-case *readtable*) :preserve)
      (set-syntax-from-char #\: #\;)
      (set-macro-character #\: (lambda (stream char) (declare (ignore stream char)) :colon))
      (set-macro-character #\newline (lambda (stream char) (declare (ignore stream char)) :newline))

      (with-open-file (stream input-pathname :direction :input)
        (let iter ((token (read stream nil :eof))
                   (line '())
                   (gates '())
                   (wires '())
                   (outputs '()))
        
          (multiple-value-bind (line* gates* wires* outputs*)
              (if (or (eq token :eof) (eq token :newline))
                  (if line
                      (if (member :colon line)
                          (values '()
                                  gates
                                  (cons `(,(third line) () ,(first line)) wires)
                                  outputs)
                          (values '()
                                  (cons `(,(maybe-swap (first line)) ()
                                          (,(ecase (fourth line)
                                              (XOR 'logxor)
                                              (OR 'logior)
                                              (AND 'logand))
                                           ,@(list (list (third line)) (list (fifth line)))))
                                        gates)
                                  wires
                                  (if (and (symbolp token)
                                           (char= (char (symbol-name token) 0) #\z))
                                      (cons `(list ,(list token)) outputs)
                                      outputs)
                                  ))
                      (values '() gates wires outputs))
                  (values (cons token line) gates wires (if (and (symbolp token)
                                                                 (char= (char (symbol-name token) 0) #\z))
                                                            (cons (list token) outputs)
                                                            outputs)))
            (if (eq token :eof)
                `(labels (,@wires*
                          ,@gates*)
                   (fold-left (lambda (acc bit)
                                (+ (* 2 acc) bit))
                              0  (list ,@(sort outputs* #'string-greaterp :key (lambda (term) (symbol-name (car term)))))))
                (iter (read stream nil :eof) line* gates* wires* outputs*))))))))

For part 2, we are told that the circuit is supposed to add two binary numbers. We are also told that the circuit the circuit has four of its wires swapped. We are asked to find the swapped wires.

It is hard to understand what is going on because almost all the wires have random three-letter names. We start by renaming the wires so that they have a bit number prefixed to with them. If a gate has two numbered inputs where the numbers are equal, we propagate the number to the output of the gate.

Once the wires are numbered, we sort the wires by their numbers and print the wire list. The regular pattern of gates is instantly obvious, and the swapped wires are easy to spot. It isn't obvious how to find the swapped wires in the general case, but it is unnecessary to solve the puzzle, so there is no code for this.

Advent of Code 2024: Day 23

For day 23 we’re going to look for cliques in a graph. A clique is a subset of vertices in a graph such that every pair of vertices in the clique is connected by an edge. In other words, a clique is a complete subgraph of the graph.

The graph is given as a list of edges. The graph is undirected, so the edge (a, b) is the same as the edge (b, a). We represent the graph as a hash table mapping vertices to a list of adjacent vertices.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY23")

(defun get-input (input-pathname)
  (let ((neighbor-table (make-hash-table :test #’eql))
        (package (find-package "ADVENT2024/DAY23")))
    (iterate (((left right) (#2M(lambda (line) (values-list (str:split #\- line)))
                                (scan-file input-pathname #’read-line))))
      (let ((left*  (intern (string-upcase left)  package))
            (right* (intern (string-upcase right) package)))
        (push right* (gethash left* neighbor-table ’()))
        (push left* (gethash right* neighbor-table ’()))))
  neighbor-table))

Given a neighbor table, we can get a list of the two vertex cliques by looking at the keys and values of the hash table.

(defun two-vertex-cliques (neighbor-table)
  (collect-append
   (mapping (((vertex neighbors) (scan-hash neighbor-table)))
     (mappend (lambda (neighbor)
                (when (string-lessp (symbol-name vertex) (symbol-name neighbor))
                  (list (list vertex neighbor))))
              neighbors))))

Given a two vertex clique, we can find a three vertex clique by looking for a vertex that is connected to both vertices in the two vertex clique. We find the neighbors of each vertex in the clique and then take the intersection of the two lists of neighbors. We distribute this intersection over the two vertex clique to get the list of three vertex cliques. Note that each three vertex clique will appear three times in the list in different orders.

In Part 1, we count the number of three vertex cliques in the graph where one of the vertices begins with the letter ‘T’. We divide by three because we generate three vertex cliques in triplicate.

(defun part-1 ()
  (/ (count-if (lambda (clique)
                 (find-if (lambda (sym)
                            (char= #\T (char (symbol-name sym) 0)))
                          clique))
               (let ((neighbor-table (get-input (input-pathname))))
                 (mappend (lambda (clique)
                            (let ((left-neighbors (gethash (first clique) neighbor-table))
                                  (right-neighbors (gethash (second clique) neighbor-table)))
                              (map ’list (lambda (common-neighbor) (list* common-neighbor clique))
                                   (intersection left-neighbors right-neighbors))))
                          (two-vertex-cliques neighbor-table))))
     3))

For Part 2, we are to find the largest maximal clique. We use the Bron-Kerbosch algorithm to find the maximal cliques.

(defun bron-kerbosch (graph-vertices clique more-vertices excluded-vertices)
  (if (and (null more-vertices) (null excluded-vertices))
      (list clique)
      (let iter ((answer '())
                 (excluded-vertices excluded-vertices)
                 (more-vertices more-vertices))
        (if (null more-vertices)
            answer
            (let* ((this-vertex (car more-vertices))
                   (more-vertices* (cdr more-vertices))
                   (neighbors (gethash this-vertex graph-vertices)))
              (iter (append (bron-kerbosch graph-vertices
                                           (adjoin this-vertex clique)
                                           (intersection more-vertices* neighbors)
                                           (intersection excluded-vertices neighbors))
                            answer)
                (adjoin this-vertex excluded-vertices)
                more-vertices*))))))

(defun maximal-cliques (graph-vertices)
  (bron-kerbosch graph-vertices ’() (hash-table-keys graph-vertices) ’()))

Once we have found the maximal cliques, we can find the largest clique by sorting the cliques by length and taking the first one. We sort the vertices in the clique and print as a comma separated list.

(defun part-2 ()
  (format
   nil "~{~a~^,~}"
   (sort
    (first
     (sort
      (maximal-cliques (get-input (input-pathname)))
      #’> :key #’length))
    #’string-lessp :key #’symbol-name)))

Advent of Code 2024: Day 22

On Day 22 we are introduced to a simple pseudo-random number generator (PRNG) that uses this recurrance to generate pseudo-random numbers:

S1 = ((Xn << 6) ⊕ Xn) mod 224
S2 = ((S1 >> 5) ⊕ S1) mod 224
Xn+1 = ((S2 << 11) ⊕ S2) mod 224

We just define this as a simple function, but we are carful to put a check-type on the input to make sure it is a number in the correct range. This gives the compiler enough information to optimize the body of the generator to a sequence of inline fixed-point operations, avoid the overhead of a function call out to the generic arithmetic.

(defun next-pseudorandom (pseudorandom)
  (check-type pseudorandom (integer 0 (16777216)))
  (macrolet ((mix (a b) ‘(logxor ,a ,b))
             (prune (x) ‘(mod ,x 16777216)))
    (let* ((s1 (prune (mix (* pseudorandom 64) pseudorandom)))
           (s2 (prune (mix (floor s1 32) s1)))
           (s3 (prune (mix (* s2 2048) s2))))
      s3)))

We can generate a series of random numbers from a given seed:

(defun scan-pseudorandom (seed)
  (declare (optimizable-series-function))
  (scan-fn '(integer 0 (16777216))
           (lambda () seed)
           #'next-pseudorandom))

The nth pseudorandom number is the nth element in the series, i.e. the result of applying the next-pseudorandom function n times to the seed:

(defun nth-pseudorandom (seed n)
  (collect-nth n (scan-pseudorandom seed)))

Part 1 of the problem is to sum the 2000th pseudorandom numbers generated from seeds given in a file.

(defun part-1 ()
  (collect-sum (#Mnth-pseudorandom (scan-file (input-pathname)) (series 2000))))

For part 2, we're going to be simulating a market. The prices are single digit pseudorandom numbers:

(defun scan-prices (seed)
  (declare (optimizable-series-function))
  (#Mmod (scan-pseudorandom seed) (series 10)))

The bidders in our market are monkeys, and we read them from our input file:

(defun scan-monkeys (input-pathname)
  (declare (optimizable-series-function 2))
  (cotruncate (scan-range :from 0)
              (scan-file input-pathname)))

The seed that we read from the input pathname will be used to create a price series for each monkey.

Each monkey looks for trends in the market by looking at the last four price changes. If the last four prices changes match the trend the monkey looks for, the monkey will make a trade and get a profit of the current price.

For part 2, we assume all the monkeys look for the same trend. Some trend will maximize the total profit of all the monkeys. We want to know what that maximum profit is.

We'll proceed in two steps. First, we make a table that maps trends to profits for each monkey. We'll start with an empty table, then we'll iterate over the monkeys, adding the trend info for that monkey. Once we have the table, we'll iterate over all the possible trends and find the one that maximizes the total profit.

price-deltas is a series of the differences between the prices in the price series. We'll use this to determine the trend.

(defun price-deltas (price-series)
  (declare (optimizable-series-function)
           (off-line-port price-series))
  (mapping (((before after) (chunk 2 1 price-series)))
     (- after before)))

price-trends is a series of trends. The trend is simply a list of the last four price deltas.

(defun price-trends (price-series)
  (declare (optimizable-series-function)
           (off-line-port price-series))
  (mapping (((d1 d2 d3 d4) (chunk 4 1 (price-deltas price-series))))
           (list d1 d2 d3 d4)))

add-trend-info! adds the trend info for a monkey to the table. We'll look at a count of 2000 prices (minus the first four because there aren't enough to establish a trend). The key to an entry in the table will be taken from the price-trends. The value for an entry is the price after that trend. The table maps a trend to an alist that maps monkeys to profits, so once we know the trend, we look to see if an entry for the monkey already exists in the value. If it does, we're done. But if it doesn't, we add an entry for the monkey with the profit.

(defun add-trend-info! (table monkeyid seed)
  (iterate ((count (scan-range :from 4 :below 2001))
            (trend (price-trends (scan-prices seed)))
            (value (subseries (scan-prices seed) 4)))
    (declare (ignore count))
    (unless (assoc monkeyid (gethash trend table '()))
      (push (cons monkeyid value) (gethash trend table '())))))

Once we have added the trend info for all the monkeys, we find the entry in the table that maximizes the total profit.

(defun trend-table-maximum (table)
  (let ((best-score 0)
        (best-key nil))
    (maphash (lambda (key value)
               (let ((score (reduce #'+ (map 'list #'cdr value))))
                 (when (> score best-score)
                   (setq best-key key)
                   (setq best-score score))))
             table)
    (values best-key best-score)))

Finally, we can put it all together in the part-2 function:

(defun part-2 ()
  (multiple-value-bind (best-key best-value)
      (let ((table (make-hash-table :test #'equal)))
        (iterate (((monkeyid seed) (scan-monkeys (input-pathname))))
          (add-trend-info! table monkeyid seed))
        (trend-table-maximum table))
    (declare (ignore best-key))
    best-value))

Advent of Code 2024: Day 21

For day 20, we are entering a combination on a numeric keypad. But we cannot just enter the combination, we have to direct a robot to enter the combination by entering the directions to move the robot. But we cannot enter the directions directly, we have to get another robot to enter the directions to move the first robot. Part 1 of the problem has two layers of robots, but part 2 has a cascade of 25 layers of robots.

The door we need to unlock has a numeric keypad, but each robot has a directional keypad. The A key is an ’enter’ key.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY21")

(defparameter *numeric-keypad* #2a(( 7  8  9)
                                   ( 4  5  6)
                                   ( 1  2  3)
                                   (nil 0  A)))

(defparameter *directional-keypad* #2a((nil |^| A)
                                       ( <  |v| >)))

(defun read-input (input-pathname)
  (collect ’list
    (#M(lambda (line)
         (collect ’list
           (#M(lambda (c)
                (or (digit-char-p c)
                    (intern (string c) (find-package "ADVENT2024/DAY21"))))
              (scan ’string line))))
       (scan-file input-pathname #’read-line))))

Given a keypad, we can find the coordinates of a key by scanning for it.

(defun key-coords (keypad key)
  (let ((coords (scan-grid-coords keypad)))
    (collect-first
     (choose
      (#Meql
       (#Mgrid-ref (series keypad) coords)
       (series key))
      coords))))

To move the robot arm, we’ll jog it vertically or horizontally by pressing keys on the directional keypad.

(defun jog-x (dx)
  (make-list (abs dx) :initial-element (if (minusp dx) ’< ’>)))

(defun jog-y (dy)
  (make-list (abs dy) :initial-element (if (minusp dy) ’|^| ’|v|)))

A valid two-dimensional jog must never go over the dead key.

(defun valid-jog? (keypad from jog)
  (let iter ((current from)
             (jog jog))
    (cond ((null (grid-ref keypad current)) nil)
          ((null jog) t)
          (t (iter (ecase (car jog)
                     (|^| (coord-north current))
                     (|v| (coord-south current))
                     (>   (coord-east  current))
                     (<   (coord-west  current)))
               (cdr jog))))))

Given the coords of a from key and a to key on a keypad, we can compute the ways to jog the arm from to to. There may be more than one way, so we return a list of the ways to jog the arm. Zig-zag jogging is never going to be optimal, so we omit that option.

(defun jog-xy (keypad from to)
  (let ((dx (jog-x (- (column to) (column from))))
        (dy (jog-y (- (row to) (row from)))))
    (cond ((null dx) (list dy))
          ((null dy) (list dx))
          (t (let ((column-first (append dx dy))
                   (row-first    (append dy dx)))
               (cond ((and (valid-jog? keypad from column-first)
                           (valid-jog? keypad from row-first))
                      (list column-first row-first))
                     ((valid-jog? keypad from column-first)
                      (list column-first))
                     (t (list row-first))))))))

In the general case, we’ll get a list of two possibilities. Either we move vertically first or we move horizontally first. One of these possibilities will lead to the shortest sequence of inputs. Oftentimes we can prune this to one possibility, e.g. we are keeping in the same row or column, or one possibility would take us over the dead key.

Instead of using coords, we would like to specify the key names.

(defun step-paths (keypad start-key end-key)
  (jog-xy keypad (key-coords keypad start-key) (key-coords keypad end-key)))

Given a target sequence we want a robot to enter into a keypad, we want to compute sequences on the robots directional keypad that we can enter to cause the robot to enter the target sequence. There will be multiple possibilities, and we want any of the shortest ones. Notice that last thing entered in a sequence is the A key, so we can assume the robot is starting from that key having pressed A in the prior sequence.

This is where we insert a memoization cache to control the combinatoric explosion that will occur when we cascade robots.

(defparameter seq-paths-cache (make-hash-table :test #’equal))

(defun seq-paths (keypad sequence)
  (if (eql keypad *numeric-keypad*)
      (seq-paths-1 keypad sequence)
      (let* ((key sequence)
             (probe (gethash sequence seq-paths-cache :not-found)))
        (if (eq probe :not-found)
            (let ((answer (seq-paths-1 keypad sequence)))
              (setf (gethash key seq-paths-cache answer) answer)
              answer)
            probe))))

(defun seq-paths-1 (keypad sequence)
  (cartesian-product-list
   (butlast (maplist (lambda (tail)
                       (cond ((null tail) nil)
                             ((null (cdr tail)) nil)
                             (t (revmap (lambda (jog)
                                          (append jog (list ’a)))
                                        (jog-xy keypad
                                                (key-coords keypad (first tail))
                                                (key-coords keypad (second tail)))))))
                     (cons ’a sequence)))))

Given the ultimate sequence we want to end up typing on the ultimate keypad, we want to move up through the cascade of robots generating meta sequences that drive the robot on the next level down. This produces a combinatoric explosion. But the puzzle doesn’t care about the actual sequence of keys, only that the number of keystrokes, is minimal, so we keep at each level the keystrokes for each target key, but we can ignore the order in which the robot presses the target keys. At each level of the robot cascade, we will know, for example, that we have to enter "move up, press A" some thirty-two times in total. This means that the robot one level up will have thirty-two copies of the "move left, press A, move right, press A" meta-sequence.

The meta sequences can be fragmented at each press of the A key and then we can count each fragment individually. So we only need to know the meta sequence for a handful of fragments to determine the number of keystrokes needed to enter a sequence. This is kept in our memoization table.

But there are multiple meta-sequences that can be expanded from a sequence. If they have different lengths, we want one of the shortest ones, but even among the shortest ones of the same length, the next level of expansion may produce meta-meta-sequences of different lengths. We can use a clever trick to prune the longer meta-meta-sequences. We pre-load the memoization cache to avoid returning alternatives that create large expansions two level up in the cascade. So now when we compute the meta-sequence we won’t compute so many alternative possibilities, but only possibilites that do not expand to longer solutions if run through the computation twice. There are eleven of these:

(defun preload-cache ()
  (clrhash seq-paths-cache)
  (setf 
   (gethash ’(|v| A)     seq-paths-cache) ’(((<  |v| A)   (^ > A)))
   (gethash ’( <  A)     seq-paths-cache) ’(((|v| < < A) (> > ^ A)))

   (gethash ’(|^|  >  A) seq-paths-cache) ’(((< A)     (|v| > A) (^ A)))
   (gethash ’(|v|  >  A) seq-paths-cache) ’(((< |v| A)     (> A) (^ A)))
   (gethash ’( >  |^| A) seq-paths-cache) ’(((|v| A)     (< ^ A) (> A)))
   (gethash ’( <  |^| A) seq-paths-cache) ’(((|v| < < A) (> ^ A) (> A)))
   (gethash ’( <  |v| A) seq-paths-cache) ’(((|v| < < A)   (> A) (^ > A)))

   (gethash ’(|v|  <   <  A) seq-paths-cache) ’(((< |v| A)     (< A)       (A) (> > ^ A)))
   (gethash ’( >   >  |^| A) seq-paths-cache) ’(((|v| A)         (A)   (< ^ A) (> A)))

   (gethash ’( >  |v| |v| |v| A) seq-paths-cache) ’(((|v| A)   (< A) (A)   (A) (^ > A)))
   (gethash ’(|v| |v| |v|  >  A) seq-paths-cache) ’(((< |v| A)   (A) (A) (> A) (^ A)))))

With the cache preloaded with these values, we always generate meta-sequences that have minimal keystrokes, but furthermore, the meta-meta-sequences will also have minimal keystrokes.

The rest of the file generates meta sequences up the cascade of robots.

(defun next-seq-tables (seq-table)
  (remove-duplicates (collapse-seq-tables (next-seq-tables-1 seq-table)) :test #’equal))

(defun collapse-seq-tables (seq-tables)
  (revmap #’collapse-seq-table seq-tables))

(defun symbol-lessp (left right)
  (string-lessp (symbol-name left) (symbol-name right)))

(defun term-lessp (left right)
  (or (and (null left) right)
      (and (null right) nil)
      (symbol-lessp (car left) (car right))
      (and (eql (car left) (car right))
           (term-lessp (cdr left) (cdr right)))))

(defun collapse-seq-table (seq-table)
  (let ((table (make-hash-table :test #’equal)))
    (dolist (entry seq-table)
      (let ((key (car entry))
            (count (cdr entry)))
        (incf (gethash key table 0) count)))
    (sort (hash-table-alist table) #’term-lessp :key #’car)))

(defun next-seq-tables-1 (seq-table)
  (if (null seq-table)
      (list (list))
      (let ((tail-tables (next-seq-tables-1 (cdr seq-table))))
        (extend-seq-tables (car seq-table) tail-tables))))

(defun extend-seq-tables (entry tail-tables)
  (revmappend (lambda (tail-table)
             (extend-seq-table entry tail-table))
           tail-tables))

(defun extend-seq-table (entry tail-table)
  (revmap (lambda (path)
            (extend-with-path path (cdr entry) tail-table))
          (seq-paths *directional-keypad* (car entry))))

(defun extend-with-path (path count tail-table)
  (append (revmap (lambda (term) (cons term count)) path)
          tail-table))

(defun seq-table-length (seq-table)
  (reduce #’+ (map ’list (lambda (entry) (* (length (car entry)) (cdr entry))) seq-table)))

The initial-paths-table takes the target numeric sequence and produces a table of the sequence fragments to enter that sequence. Order is not presevered.

(defun initial-paths-table (numeric-seq)
  (map ’list (lambda (path)
                (let ((table (make-hash-table :test #’equal)))
                  (dolist (term path (hash-table-alist table))
                    (incf (gethash term table 0)))))
       (seq-paths *numeric-keypad* numeric-seq)))

We generate the table for a generation by iteratively calling next-seq-tables until we reach the number of robots in the cascade.

(defun generation-table (n numeric-seq)
  (if (zerop n)
      (initial-paths-table numeric-seq)
      (revmappend #’next-seq-tables (generation-table (1- n) numeric-seq))))

(defun shortest-table (sequence-tables)
  (car (sort sequence-tables #’< :key #’seq-table-length)))

Finally, we can compute the complexity of the sequence by counting the number of keypresses in the shortest sequence and multiplying by the code in the sequence.

(defun complexity (code n-generations)
    (* (seq-table-length (shortest-table (generation-table n-generations code)))
       (fold-left (lambda (acc digit)
                    (if (eql digit ’a)
                        acc
                        (+ (* acc 10) digit)))
                  0
                  code)))

And we can compute the answer to part 1 and part 2 with a cascade of two robots and a cascade of twenty-five robots respectively.

(defun part-1 ()
  (reduce #’+ (map ’list (lambda (input) (complexity input 2)) (read-input (input-pathname)))))

(defun part-2 ()
  (reduce #’+ (map ’list (lambda (input) (complexity input 25)) (read-input (input-pathname)))))

Advent of Code 2024: Day 20

For day 20, we return to a maze problem. The maze involved, however, is trivial — there are no decision points, it is just a convoluted path.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY20")

(defun read-input (input-pathname)
  (read-file-into-grid
    (char-interner #’identity (find-package "ADVENT2024/DAY20"))
     input-pathname))

(defun find-start-and-goal (maze)
  (let ((inverse (invert-grid maze ’|.|)))
    (values (car (gethash ’S inverse))
            (car (gethash ’E inverse)))))

We compute the distance to the goal at all points along the path by walking the path backwards.

(defun compute-distances (maze)
  (let ((distances (make-grid (grid-height maze) (grid-width maze)
                              :initial-element nil)))
    (multiple-value-bind (start goal) (find-start-and-goal maze)
      (declare (ignore start))
      (let iter ((current goal)
                 (distance 0))
        (when current
          (setf (grid-ref distances current) distance)
          (iter (let* ((neighbors (#M2v+ (scan ’list (list +north+ +south+ +east+ +west+))
                                     (series current)))
                       (fill? (#M(lambda (maze neighbor)
                                   (and (on-grid? maze neighbor)
                                        (not (eql (grid-ref maze neighbor) ’\#))
                                        (null (grid-ref distances neighbor))))
                                 (series maze)
                                 neighbors)))
                  (collect-first (choose fill? neighbors)))
                (1+ distance))))
      distances)))

When we run through the maze we are allowed to cheat just once by walking through a wall. For part 1, we can walk just one step through a wall, but for part 2, we can walk up to 20 steps ignoring the walls. We might as well combine the two solutions into a single parameterized function. We will be asked to count the number of cheats that shorten the path by at least 100 steps.

I tried for quite some time to come up with a series oriented way to solve this, but it turned out to be much easier to just write a named-let iterative loop. So much for series.

First, we have a function that finds the cheats for a specific location. We are given a grid of distances to the goal, a coord that we start from, the current distance to the goal, the number of steps we can take through the walls, and the number of steps we have to shave off to count this cheat.

We iterate in a square grid centered at the current location and twice as wide plus one as the cheat steps. Check the locations in the distance grid that fall within the square and this tells us how much closer to the goal we can get by cheating to that location. We have to add in the manhattan distance from the current location to the cheat location to get the total distance. Subtract that from the original distance to the goal and we have the number of steps we save by using this cheat. If it exceeds our threshold, we count it.

(defun scan-square-coords (size)
  (declare (optimizable-series-function))
  (let ((displacement (coord size size)))
    (#M2v- (scan-coords (1+ (* size 2)) (1+ (* size 2)))
           (series displacement))))

(defun count-location-cheats (distances coord distance cheat-steps threshold)
  (collect-sum
   (choose
    (mapping (((cheat-vec) (scan-square-coords cheat-steps)))
      (let ((manhattan-distance (+ (abs (column cheat-vec)) (abs (row cheat-vec))))
            (cheat-coord (2v+ coord cheat-vec)))
        (and (<= manhattan-distance cheat-steps)
             (on-grid? distances cheat-coord)
             (let ((cheat-distance (grid-ref distances cheat-coord)))
               (and cheat-distance
                    (let* ((distance-if-cheating (+ manhattan-distance cheat-distance))
                           (savings (- distance distance-if-cheating)))
                      (and (>= savings threshold)
                           1))))))))))

So then we just iterate over the locations in the distance grid and call this function for each location, summing the results.

(defun count-cheats (distances-grid cheat-steps threshold)
  (collect-sum
   (choose
    (mapping (((coord distance) (scan-grid distances-grid)))
      (and distance
           (count-location-cheats distances-grid coord distance cheat-steps threshold))))))

For part 1, we can only take two steps through a wall.

(defun part-1 ()
  (count-cheats (compute-distances (read-input (input-pathname))) 2 100))

For part 2, we can take up to 20 steps through a wall.

(defun part-2 ()
  (count-cheats (compute-distances (read-input (input-pathname))) 20 100))

Advent of Code 2024: Day 19

For day 19, we are constructing sequences from fragments. We are first given a list of fragments, separated by commas. For example:

r, wr, b, g, bwu, rb, gb, br

The we are given a series of sequences that we need to construct by concatenating the fragments. For example:

brwrr  = br + wr + r
bggr   = b + g + g + r

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY19")

(defun read-input (input-pathname)
  (let ((parsed
          (collect 'list
            (#M(lambda (line)
                 (map 'list #'str:trim (str:split #\, line)))
               (scan-file input-pathname #'read-line)))))
    (values (first parsed) (map 'list #'first (rest (rest parsed))))))

Our job is to determine if the sequences can be constructed from the fragments. This is an easy recursive predicate:

(defun can-make-sequence? (fragments sequence)
  (or (zerop (length sequence))
      (some
       (lambda (fragment)
         (multiple-value-bind (prefix? suffix)
             (starts-with-subseq fragment sequence :return-suffix t)
           (and prefix?
                (can-make-sequence? fragments suffix))))
      fragments)))

Part 1 is to determine how many of the sequences can be constructed from the fragments.

(defun part-1 ()
  (multiple-value-bind (fragments sequences) (read-input (input-pathname))
    (count-if (lambda (sequence)
                  (can-make-sequence? fragments sequence))
              sequences)))

Part 2 is to count the number of ways we can construct the sequences from the fragments. Naively, we would just count the number of ways we can construct each sequence using each of the fragments as the first fragment and then sum them.

(defun count-solutions (fragments sequence)
  (if (zerop (length sequence))
      1
      (collect-sum
        (#M(lambda (fragment)
             (multiple-value-bind (prefix? suffix)
                 (starts-with-subseq fragment sequence :return-suffix t)
               (if prefix?
                   (count-solutions fragments suffix)
                   0)))
          (scan 'lists fragments)))))

But the naive approach won’t work for the larger input. The combinatorics grow far too quickly, so we need to be more clever. One possible way to do this is with “dynamic programming”, but most of the times I've seen this used, it involved a table of values and you had to invert your solution to fill in the table from the bottom up. But this is unnecessarily complicated. It turns out that “dynamic programming” is isomorphic to simple memoized recursive calls. So we won't bother with the table and inverting our solution. We'll just add some ad hoc memoization to our recursive count-solutions:

(defparameter *count-solutions-cache* (make-hash-table :test 'equal))

(defun count-solutions (fragments sequence)
  (let ((key (cons fragments sequence)))
    (or (gethash key *count-solutions-cache*)
        (setf (gethash key *count-solutions-cache*)
              (if (zerop (length sequence))
                  1
                  (collect-sum
                    (#M(lambda (fragment)
                         (multiple-value-bind (prefix? suffix)
                             (starts-with-subseq fragment sequence :return-suffix t)
                           (if prefix?
                               (count-solutions fragments suffix)
                               0)))
                      (scan 'list fragments))))))))

(defun part-2 ()
  (multiple-value-bind (fragments sequences) (read-input (input-pathname))
    (collect-sum
     (#M(lambda (sequence)
          (count-solutions fragments sequence))
        (scan ’list sequences)))))

This runs at quite a reasonable speed.

Advent of Code 2024: Day 18

For day 18, we have a maze again, but this time the input is given as coordinate pairs of where the walls go. The start and goal are the upper left and lower right respectively.

(in-package "ADVENT2024/DAY18")

(defun read-input (file grid n-bytes)
  (iterate ((coord (#M(lambda (line)
                       (apply #’coord (map ’list #’parse-integer (str:split #\, line))))
                      (cotruncate (scan-file file #’read-line)
                                  (scan-range :below n-bytes)))))
    (setf (grid-ref grid coord) ’\#))
  (setf (grid-ref grid (coord 0 0)) ’|S|)
  (setf (grid-ref grid (coord (1- (grid-height grid)) (1- (grid-width grid)))) ’|E|))

(defun sample-input ()
  (let ((grid (make-array (list 7 7) :initial-element ’|.|)))
    (read-input (sample-input-pathname) grid 12)
    grid))

(defun input (n-bytes)
  (let ((grid (make-grid 71 71 :initial-element ’|.|)))
    (read-input (input-pathname) grid n-bytes)
    grid))

The bulk of the solution simply reuses the Dijkstra’s algorithm from day 16. I won’t reproduce the code here. We just adjust the path scorer to not penalize for turns.

For part 1, we load the first 1024 walls and find a shortest path.

(defun part-1 ()
  (let* ((grid (input 1024))
         (solutions (solve-maze grid)))
    (score-path (car solutions))))

For part 2, we want to find the first wall in the list of walls that prevents us from reaching the goal. Binary search time.

(defun total-walls ()
  (collect-length (scan-file (input-pathname) #’read-line)))

(defun binary-search (pass fail)
  (if (= (1+ pass) fail)
      (list pass fail)
      (let* ((mid (floor (+ pass fail) 2))
             (grid (input mid)))
        (let ((solutions (solve-maze grid)))
          (if (null solutions)
              (binary-search pass mid)
              (binary-search mid fail))))))

(defun get-coord (n)
  (collect-nth n (scan-file (input-pathname) #’read-line)))

(defun part-2 ()
  (collect-nth (car (binary-search 1024 (total-walls)))
  (scan-file (input-pathname) #’read-line)))

Advent of Code 2024: Day 17

For day 17, we are emulating a small processor. The processor has 4 registers, a, b, and c, and a program counter. The program is an array of instructions, each of which is an integer.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY17")

(defstruct (machine
            (:type vector)
            (:conc-name machine/))
  (pc 0)
  a
  b
  c
  (program (vector) :read-only t))

To read a machine from the input file, we build a keyword argument list for the MAKE-MACHINE function and then apply the function:

(defun read-machine (filename)
  (apply #’make-machine
         (collect-append
          (choose
           (#M(lambda (line)
                (cond ((str:starts-with? "Register A:" line)
                       (list :a (parse-integer (subseq line 11))))
                      ((str:starts-with? "Register B:" line)
                       (list :b (parse-integer (subseq line 11))))
                      ((str:starts-with? "Register C:" line)
                       (list :c (parse-integer (subseq line 11))))
                      ((str:starts-with? "Program:" line)
                       (list :program (collect ’vector
                                        (choose
                                         (#Mdigit-char-p
                                          (scan ’string (subseq line 9)))))))
                      (t nil)))
              (scan-file filename #’read-line))))))

To run the machine, we sit in a loop, reading the instruction at the program counter, and then using an ECASE to dispatch to the appropriate operation. We symbol-macrolet the parts of an instruction so that instructions appear to be simple assignments.

(defun run-machine (machine)
  (symbol-macrolet ((a  (machine/a machine))
                    (b  (machine/b machine))
                    (c  (machine/c machine))
                    (pc (machine/pc machine))
                    (program (machine/program machine))
                    (immediate (svref program (1+ pc)))
                    (argument (ecase immediate
                                (0 0)
                                (1 1)
                                (2 2)
                                (3 3)
                                (4 a)
                                (5 b)
                                (6 c)))
                    (next-instruction (progn (incf pc 2)
                                             (iter))))

    (let ((output ’()))
      (let iter ()
        (if (>= pc (length program))
            (reverse output)
            (ecase (svref program pc)
              (0 (setf a (truncate a (expt 2 argument))) next-instruction)
              (1 (setf b (logxor b immediate))           next-instruction)
              (2 (setf b (mod argument 8))               next-instruction)

              (3
               (if (zerop a)
                   next-instruction
                   (progn
                     (setf pc immediate)
                     (iter))))

              (4 (setf b (logxor b c))                   next-instruction)
              (5 (push (mod argument 8) output)          next-instruction)
              (6 (setf b (truncate a (expt 2 argument))) next-instruction)
              (7 (setf c (truncate a (expt 2 argument))) next-instruction)))))))

For part 1, we simply run the machine as given in the input file and print the output as comma separated integers:

(defun part-1 ()
  (format nil "~{~d~^,~}" 
    (run-machine (read-machine (input-pathname)))))

For part 2, we seek an initial value of the A register that will cause the machine to output its own program. We search for the value of A one digit at a time:

(defun get-machine-state (machine)
  (list (machine/pc machine)
        (machine/a machine)
        (machine/b machine)
        (machine/c machine)))

(defun set-machine-state! (machine state)
  (setf (machine/pc machine) (first state)
        (machine/a machine) (second state)
        (machine/b machine) (third state)
        (machine/c machine) (fourth state)))

(defun try-machine (machine state input-a)
  (set-machine-state! machine state)
  (setf (machine/a machine) input-a)
  (run-machine machine))

(defun pad-terms (terms size)
  (revappend (make-list (- size (length terms)) :initial-element 0) terms))

(defun from-octal (octal-digits)
  (fold-left (lambda (n digit) (+ (* n 8) digit)) 0 (reverse octal-digits)))

(defun part-2 ()
  (let* ((machine (read-machine (input-pathname)))
         (initial-state (get-machine-state machine))
         (target (machine/program machine)))
    (let term-loop ((terms ’())
                    (index (1- (length target))))
      (if (= index -1)
          (from-octal terms)
          (let digit-loop ((digit 0))
            (if (> digit 7)
                (error "No solution")
                (let* ((padded (pad-terms (cons digit terms) (length target)))
                       (output (try-machine machine initial-state (from-octal padded))))
                  (if (and (= (length output) (length target))
                           (= (elt output index) (svref target index)))
                      (term-loop (cons digit terms) (1- index))
                      (digit-loop (1+ digit))))))))))

The outer iteration in part-2 is over the program instructions. If the index is -1, we have found the solution. Otherwise, we iterate over the digits 0-7, trying each one in turn. We pad the terms with zeros to make an octal input number, run the machine, and check the output. If the output matches the target, we move to the next term. Otherwise, we increment the digit.

Advent of Code 2024: Day 16

For day 16, we are solving a maze. We want to find the lowest cost path from the start to the end. Taking a step straight ahead costs 1, but turning left or right costs 1000.

This puzzle was the most vexing of all the puzzles. The solution is straightforward but the devil is the details. I found myself constantly mired in the CARs and CDRs of the path data structure, descending too far or not far enough. I tried several different representations for a path, each one with its own set of problems. Trying to keep track of the direction of the steps in the path turned out to be an exercise in frustration.

The algorithm is a variant of Dijkstra’s algorithm, which finds the shortest weighted path in a graph. In our case, the graph is derived from the maze. The vertices of the graph are the locations in the maze with three or more paths leading out of them. The edges in the graph are the steps between the vertices. But you cannot compute the cost of a path by summing the weights of the edges, as the final edge in the path may be reached either by proceeding straight through the prior vertex, or by turing left or right at the prior vertex. Thus I modified Dijkstra's algorithm to be edge-oriented rather than vertex-oriented. This turned out to be a key to solving the problem. With the vertex-oriented solutions, I had to keep track of the orientation of the path as it entered and left the vertex, and annotating the steps along the path with their orientation turned into a bookkeeping nightmare. With the edge-oriented solution, I could discard the orientation information as I advanced the algorithm and reconstruct the orientation information only after I had generated a candidate path. This greatly simplified the bookkeeping.

The algorithm uses a pure functional weight-balanced binary tree as a priority queue for the paths. The tree is kept in order of increasing path score, so the lowest scoring path is always the leftmost path in the tree. In my original implementation, I punted and used a linear priority queue. This is simple, and it works, but is far too slow. The weight-balanced binary tree was cribbed from MIT-Scheme.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY16")

(defun read-input (input-pathname)
  (read-file-into-grid
    (char-interner #’identity (find-package "ADVENT2024/DAY16"))
     input-pathname))

(defun start-and-goal (maze)
  (let ((inverse (invert-grid maze ’|.|)))
    (values (first (gethash ’S inverse))
            (first (gethash ’E inverse)))))

Since Dijkstra’s algorithm is a graph algorithm, we need to represent the maze as a graph. We simplify the graph by flooding the dead ends.

(defun dead-end? (maze coord)
  (and (on-grid? maze coord)
       (eql (grid-ref maze coord) ’|.|)
       (let ((n (coord-north coord))
             (s (coord-south coord))
             (e (coord-east coord))
             (w (coord-west coord)))
         (let ((n* (or (not (on-grid? maze n))
                       (eql (grid-ref maze n) ’\#)))
               (s* (or (not (on-grid? maze s))
                       (eql (grid-ref maze s) ’\#)))
               (e* (or (not (on-grid? maze e))
                       (eql (grid-ref maze e) ’\#)))
               (w* (or (not (on-grid? maze w))
                       (eql (grid-ref maze w) ’\#))))
           (or (and n* e* w*)
               (and e* n* s*)
               (and s* e* w*)
               (and w* n* s*))))))

(defun flood-dead-end! (maze coord)
  (when (dead-end? maze coord)
    (setf (grid-ref maze coord) ’\#)
    (flood-dead-end! maze (coord-north coord))
    (flood-dead-end! maze (coord-south coord))
    (flood-dead-end! maze (coord-east coord))
    (flood-dead-end! maze (coord-west coord))))

(defun flood-dead-ends! (maze)
  (iterate ((coord (scan-grid-coords maze)))
    (flood-dead-end! maze coord)))

We then mark the vertices of the graph by looking for locations with three or more paths leading out of them.

(defun vertex? (maze coord)
  (and (on-grid? maze coord)
       (eql (grid-ref maze coord) ’|.|)
       (let ((n (coord-north coord))
             (s (coord-south coord))
             (e (coord-east coord))
             (w (coord-west coord)))
         (let ((n* (and (on-grid? maze n) (member (grid-ref maze n) ’(\. + S E))))
               (s* (and (on-grid? maze s) (member (grid-ref maze s) ’(\. + S E))))
               (e* (and (on-grid? maze e) (member (grid-ref maze e) ’(\. + S E))))
               (w* (and (on-grid? maze w) (member (grid-ref maze w) ’(\. + S E)))))
           (or (and n* e* w*)
               (and e* n* s*)
               (and s* e* w*)
               (and w* n* s*))))))

(defun mark-vertices! (maze)
  (let ((vertices ’()))
    (iterate ((coord (scan-grid-coords maze)))
      (when (vertex? maze coord)
        (setf (grid-ref maze coord) ’+)
        (push coord vertices)))
    vertices))

After flooding the dead ends and marking the vertices, all the edges begin and end at a vertex.

It isn’t necessary for the solution, but it helps to be able to visualize the maze. The show-maze procedure will print the maze to the standard output. The show-maze procedure takes an optional list of coords to highlight in the maze.

(defun show-maze (maze &optional highlight)
  (format t "~&")
  (dotimes (row (grid-height maze))
    (format t "~%")
    (dotimes (col (grid-width maze))
      (cond ((eql (grid-ref maze (coord col row)) ’\#)
             (format t "#"))
            ((member (coord col row) highlight :test #’equal)
             (format t "O"))
            ((eql (grid-ref maze (coord col row)) ’|S|)
             (format t "S"))
            ((eql (grid-ref maze (coord col row)) ’|E|)
             (format t "E"))
            ((eql (grid-ref maze (coord col row)) ’+)
             (format t "+"))
            (t
             (format t "."))))))

Between the vertices, we have the edges of the graph. An edge is simply the a list of coordinates between two vertices. The first and last coordinates of the edge are vertices. To find all the coordinates between two vertices, we walk the edge from the start until we reach another vertex. We don’t maintain direction. Instead, we just make sure that the new coordinate isn’t the last one in the edge we are walking so that we move forward.

(defun walk-edge (maze coord edge)
  (let ((n (coord-north coord))
        (s (coord-south coord))
        (e (coord-east coord))
        (w (coord-west coord)))
    (cond ((and (on-grid? maze n)
                (not (equal n (first edge)))
                (eql (grid-ref maze n) ’|.|))
           (walk-edge maze n (cons coord edge)))
          ((and (on-grid? maze n)
                (not (equal n (first edge)))
                (member (grid-ref maze n) ’(+ S E)))
           (list* n coord edge))
          ((and (on-grid? maze e)
                (not (equal e (first edge)))
                (eql (grid-ref maze e) ’|.|))
           (walk-edge maze e (cons coord edge)))
          ((and (on-grid? maze e)
                (not (equal e (first edge)))
                (member (grid-ref maze e) ’(+ S E)))
           (list* e coord edge))
          ((and (on-grid? maze s)
                (not (equal s (first edge)))
                (eql (grid-ref maze s) ’|.|))
           (walk-edge maze s (cons coord edge)))
          ((and (on-grid? maze s)
                (not (equal s (first edge)))
                (member (grid-ref maze s) ’(+ S E)))
           (list* s coord edge))
          ((and (on-grid? maze w)
                (not (equal w (first edge)))
                (eql (grid-ref maze w) ’|.|))
           (walk-edge maze w (cons coord edge)))
          ((and (on-grid? maze w)
                (not (equal w (first edge)))
                (member (grid-ref maze w) ’(+ S E)))
           (list* w coord edge)))))

Given a vertex, we can find all the edges that lead out of that vertex.

(defun vertex-edges (maze vertex)
  (let ((n (coord-north vertex))
        (s (coord-south vertex))
        (e (coord-east vertex))
        (w (coord-west vertex))
        (edges ’()))
    (when (and (on-grid? maze n) (member (grid-ref maze n) ’(|.| + S E)))
      (push (walk-edge maze n (list vertex)) edges))
    (when (and (on-grid? maze s) (member (grid-ref maze s) ’(|.| + S E)))
      (push (walk-edge maze s (list vertex)) edges))
    (when (and (on-grid? maze e) (member (grid-ref maze e) ’(|.| + S E)))
      (push (walk-edge maze e (list vertex)) edges))
    (when (and (on-grid? maze w) (member (grid-ref maze w) ’(|.| + S E)))
      (push (walk-edge maze w (list vertex)) edges))
    edges))

Given the ordered list of coords in a path through the maze, we need to be able to score it. There is a cost of 1 for every step, and a cost of 1000 for every turn. We calculate these separately.

To find the directions of the steps in the path, we examine adjacent coords. If the columns are the same, the direction is north/south. If the rows are the same, the direction is east/west. The very first direction is east/west because the start is always facing east. Once we have a sequence of the directions, we examine adjacent directions to see if they are the same. If they are, we went straight, otherwise we turned.

(defun count-turns (coord-list)
  (multiple-value-bind (bs as)
      (chunk 2 1 (multiple-value-bind (ls rs) (chunk 2 1 (scan ’list coord-list))
                   (catenate (#M(lambda (l r)
                                  (cond ((= (column l) (column r)) ’ns)
                                        ((= (row l) (row r)) ’ew)
                                        (t (error "Funky coord-list."))))
                                ls
                                rs)
                             (scan ’list (list ’ew)))))
    (collect-length (choose (#Mnot (#Meq bs as))))))

(defun score-coord-list (coord-list)
  (1- (+ (length coord-list)
         (* 1000 (count-turns coord-list)))))

We represent a path as a list of edges. Given a list of edges, we need to stitch them together to create a list of coords in order to score the path. We cannot simply append the edges together, as the vertices between the edges will be duplicated. Instead, we drop the last coord (the ending vertex) from each edge except the first.

(defun at-goal? (path goal)
  (equal (first (first path)) goal))

(defun path->coord-list (path)
  (if (null (rest path))
      (first path)
      (append (butlast (first path)) (path->coord-list (rest path)))))

Given a path, we can extend it by finding the edges that lead out of the last vertex in the path. We discard the edge that came into the vertex, as we don’t want to backtrack.

(defun path-extensions (maze path)
  (let* ((latest-edge (first path))
         (latest-vertex (first latest-edge))
         (back-edge (reverse latest-edge))
         (outgoing-edges (remove back-edge (vertex-edges maze latest-vertex) :test #’equal)))
    (map ’list (lambda (edge) (cons edge path)) outgoing-edges)))

As I mentioned earlier, we use a weight-balanced binary tree as a priority queue. I didn’t bother trying to abstract this. I’m just manipulate the raw nodes of the tree. Each node has a key, which is the score, and a value, which is a list of paths that have that score. We compare keys with the < function. Weight-balanced binary trees are pure functional — adding or popping the queue returns a new queue rather than side effecting the existing one.

(defun make-priority-queue ()
  wtree::empty)

(defun pq-insert (pq entry score)
  (let* ((probe (wtree::node/find #’< pq score)))
    (wtree::node/add #’< pq score (cons entry (and probe (wtree::node/v probe))))))

(defun pq-pop (pq)
  (let* ((node (wtree::node/min pq))
         (score (wtree::node/k node))
         (value-list (wtree::node/v node))
         (value (car value-list))
         (tail (cdr value-list)))
    (if (null tail)
        (values value score (wtree::node/delmin pq))
        (values value score (wtree::node/add #’< (wtree::node/delmin pq) score tail)))))

We finally arrive at the solve-maze procedure. This proceeds in three parts. First, we prepare the maze by flooding the dead ends and marking the vertices. We initialize visited-edges which is a hash table mapping an edge to the lowest score that has been found for a path ending in that edge. We initialize predecessor-edges which is a hash table mapping an edge to the edge that came before it in the lowest scoring path. The initial edges are the ones leading out of the start vertex, and the initial paths are the paths each containing one of the initial edges.

The second part is the main iteration. The outer iteration pops the lowest scoring path so far from the priority queue. If the path ends at the goal, we have found one solution and we proceed to part three where we collect other solutions that with the same score that end at the goal. Otherwise, we enter an inner loop over all ways we can extend the path by one edge. For each extension, we score the extension and look up the most recent edge in the visited-edges.

If we have not visited the edge before, we store the edge in visited-edges and store its predecessor in predecessor-edges. If we have visited the edge before, we have three cases. If the score of the extension is greater that the score we have seen before, we discard the extension. If the score of the extension is equal to the score we have see before, we add the edge preceeding the final edge to the predecessor-edges, but do not pursue this path further. If the score of the extension is less than the score we have previously found, we update the visited-edges with the new lower score and update the predecessor-edges so that this path is the only path leading to the final edge.

When we find a path that ends at the goal, we enter the third part of the procedure. We pop paths from the priority queue collecting any other paths that have also reached the goal with the same score. Finally, we return the list of shortest paths.

(defun solve-maze (maze)
  (flood-dead-ends! maze)
  (mark-vertices! maze)
  (multiple-value-bind (start goal)
      (start-and-goal maze)
    (let* ((visited-edges     (make-hash-table :test ’equal))
           (predecessor-edges (make-hash-table :test ’equal))
           ;; The initial edges are the ones that start at the start vertex.
           (initial-edges (vertex-edges maze start))
           ;; A path is a list of edges.  An initial path is a list of one edge starting at the start vertex.
           (initial-paths (map ’list #’list initial-edges)))

      (dolist (edge initial-edges)
        (setf (gethash edge visited-edges) (score-path (list edge))))

      ;; Main loop, iteratively extend the lowest scoring path.
      (let iter ((scored-paths (do ((pq (make-priority-queue) (pq-insert pq (car initial-paths) (score-path (car initial-paths))))
                                    (initial-paths initial-paths (cdr initial-paths)))
                                   ((null initial-paths) pq))))
        (unless (wtree::empty? scored-paths)
          (multiple-value-bind (path path-score next-scored-paths) (pq-pop scored-paths)
            (if (at-goal? path goal)
                ;; Reached the goal.  Keep popping until we have all solutions.
                (let solution-iter ((solutions (list path))
                                    (next-scored-paths next-scored-paths))
                  (if (wtree::empty? next-scored-paths)
                      solutions
                      (multiple-value-bind (other-path other-path-score next-scored-paths) (pq-pop next-scored-paths)
                        (if (= other-path-score path-score)
                            (solution-iter (if (at-goal? other-path goal)
                                               (cons other-path solutions)
                                               solutions)
                                           next-scored-paths)
                            (values solutions predecessor-edges)))))
                (let iter1 ((extensions (path-extensions maze path))
                            (next-scored-paths next-scored-paths))
                  (if (null extensions)
                      (iter next-scored-paths)
                      (let* ((extension (first extensions))
                             (extension-score (score-path extension))
                             (latest-edge (first extension))
                             (predecessor (second extension))
                             (prior-score (gethash latest-edge visited-edges)))
                        (cond ((null prior-score)
                               (setf (gethash latest-edge visited-edges) extension-score
                                     (gethash latest-edge predecessor-edges) (list predecessor))
                               (iter1 (rest extensions)
                                      (pq-insert next-scored-paths extension extension-score)))
                              ;; If we have found an extension with a worse score, we ignore it.
                              ((> extension-score prior-score)
                               (iter1 (rest extensions) next-scored-paths))
                              ;; If we have found an extension with an equal score, we add the predecessor,
                              ;; but do not pursue it further.
                              ((= extension-score prior-score)
                               (push predecessor (gethash latest-edge predecessor-edges))
                               (iter1 (rest extensions) next-scored-paths))
                              ;; If we have found an extension with a better score, we replace the prior extension.
                              ((< extension-score prior-score)
                               (setf (gethash latest-edge visited-edges) extension-score
                                     (gethash latest-edge predecessor-edges) (list predecessor))
                               (iter1 (rest extensions)
                                      (pq-insert next-scored-paths extension extension-score))))))))))))))

Of note is how the inner and outer iterations interact. The inner iteration is initialized with one of the loop variables of the outer loop. When the inner loop is done, it tail calls the outer loop with the loop variable it originally got from the outer loop. This gives the effect of the inner loop sharing a loop variable with the outer loop.

collect-minimum-coords collects all the coords along all minimal paths that lead through edges on the edge list.

(defun collect-minimum-coords (edge-list predecessor-table)
  (fold-left (lambda (coords edge)
               (union coords
                      (union edge (collect-minimum-coords (gethash edge predecessor-table) predecessor-table)
                             :test #’equal)
                      :test #’equal))
             ’()
             edge-list))

For part 1 of the puzzle, we solve the maze and return the score of a shortest path.

(defun part-1 ()
  (let ((maze (read-input (input-pathname))))
    (multiple-value-bind (paths predecessor-table) (solve-maze maze)
      (declare (ignore predecessor-table))
      (score-path (first paths)))))

For part 2 of the puzzle, we solve the maze and collect the coords of all the minimal paths that lead through the edges of the shortest paths.

(defun part-2 ()
  (let ((maze (read-input (input-pathname))))
    (multiple-value-bind (paths predecessor-table) (solve-maze maze)
      (let ((minimum-coords (collect-minimum-coords (map ’list #’first paths) predecessor-table)))
        (length minimum-coords)))))

Advent of Code 2024: Day 15

For day 15, we are simulating moving crates around a warehouse. We are give a map of the warehouse which we will read into a grid, and a list of moves of our little robot. When the robot encounters a crate, it will push it in the direction it is moving, if it can. If the crate rests against another crate, it will push both crates. If the crate rests against a wall, it will not move. If the crate cannot move, the robot doesn’t move either. The robot can only push.

The second part of the puzzle uses double-wide crates, so our input code has a flag to indicate whether to create single-wide or double-wide crates in the initial grid.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY15")

(defun decode-cell (string package wide?)
  (if wide?
      (cond ((equal string "#") (list ’\# ’\#))
            ((equal string "O") (list ’[ ’]))
            ((equal string ".") (list ’\. ’\.))
            ((equal string "@") (list ’@ ’\.))
            (t (error "Unknown cell ~a" string)))
      (list (intern (string-upcase string) package))))

In the input, the directions are represented with the characters ^, v, <, and >. We will convert these to the corresponding vectors.

(defun decode-move (move)
  (cond ((equal move "<") +west+)
        ((equal move "^") +north+)
        ((equal move ">") +east+)
        ((equal move "v") +south+)
        (t (error "Unknown move ~a" move))))

We’ll use a regular expression to parse the input. If it is a line consisting of #, O, ., or @, we’ll decode it as a row of the grid. If it is a line consisting of one of the directions, we’ll decode it as a move.

(defun read-input (input-pathname &optional (wide? nil))
  (multiple-value-bind (blanks grids moves)
      (#3M(lambda (line)
            (cl-ppcre:register-groups-bind (blank grid move)
                ("(^$)|([#.O@]+)|([><v^]+)" line)
              (values blank grid move)))
          (scan-file input-pathname #’read-line))
    (let ((blank-lines (collect ’list (choose blanks)))
          (grid-lines  (collect ’list
                         (#M(lambda (line)
                              (collect-append (#Mdecode-cell
                                               (#Mstring (scan ’string line))
                                               (series (find-package "ADVENT2024/DAY15"))
                                               (series wide?))))
                            (choose grids))))
          (move-list (collect-append (#M(lambda (line)
                                          (collect ’list (#Mdecode-move
                                                           (#Mstring (scan ’string line)))))
                                        (choose moves)))))
      (declare (ignore blank-lines))
      (values (make-grid (length grid-lines) (length (first grid-lines)) :initial-contents grid-lines)
              move-list))))

can-move-to? will determine if we can move to a particular cell in the grid from a particular direction. If the cell is empty, we can move there. If the cell is a crate, we can move there if we can move the crate.

(defun can-move-to? (grid coord delta)
  "True if location on grid at coord is empty, or item at location can move in direction."
  (and (on-grid? grid coord)
       (or (eql (grid-ref grid coord) ’\.)
           (can-move? grid coord delta))))

can-move? will determine if we can move an item on the grid one step in a particular direction. The tricky part is double wide crates. We need to check both cells to see if we can move the entire crate.

(defun can-move? (grid coord delta)
  "True if item on grid at coord can move in direction."
  (and (on-grid? grid coord)
       (ecase (grid-ref grid coord)
         (\. (error "No item at coord."))
         (\# nil)
         (@ (let ((target (2v+ coord delta)))
               (can-move-to? grid target delta)))
         (O (let ((target (2v+ coord delta)))
               (can-move-to? grid target delta)))
         (\[ (if (or (equal delta +north+)
                      (equal delta +south+))
                  (let ((target1 (2v+ coord delta))
                        (target2 (2v+ (2v+ coord delta) +east+)))
                    (and (can-move-to? grid target1 delta)
                         (can-move-to? grid target2 delta)))
                  (let ((target (2v+ coord delta)))
                    (can-move-to? grid target delta))))
         (\] (if (or (equal delta +north+)
                      (equal delta +south+))
                  (let ((target1 (2v+ coord delta))
                        (target2 (2v+ (2v+ coord delta) +west+)))
                    (and (can-move-to? grid target1 delta)
                         (can-move-to? grid target2 delta)))
                  (let ((target (2v+ coord delta)))
                    (can-move-to? grid target delta)))))))

move! will move an item on the grid one step in a particular direction if possible. It returns the new grid location if it moved, or nil if it didn’t. When moving an item we put a blank spot where the item was. The tricky part is double-wide crates, where we need to move both cells.

(defun move! (grid coord delta)
  "Move item on grid at coord in direction delta."
  (if (can-move? grid coord delta)
      (ecase (grid-ref grid coord)
        (\. (error "Cannot move empty locations."))
        (\# (error "Cannot move walls."))
        (@ (let ((target (2v+ coord delta)))
               (unless (eql (grid-ref grid target) ’\.)
                 (move! grid target delta))
               (setf (grid-ref grid target) ’@
                     (grid-ref grid coord) ’\.)
               target))

        (O (let ((target (2v+ coord delta)))
               (unless (eql (grid-ref grid target) ’\.)
                 (move! grid target delta))
               (setf (grid-ref grid target) ’O
                     (grid-ref grid coord) ’\.)
               target))

        (\[ (let* ((targetl (2v+ coord delta))
                    (targetr (2v+ targetl +east+)))
               (unless (or (eql delta +east+)
                           (eql (grid-ref grid targetl) ’|.|))
                 (move! grid targetl delta))
               (unless (or (eql delta +west+)
                           (eql (grid-ref grid targetr) ’\.))
                 (move! grid targetr delta))
               (setf (grid-ref grid targetl) ’[
                     (grid-ref grid targetr) ’])
               (unless (eql delta +east+)
                 (setf (grid-ref grid (2v+ coord +east+)) ’\.))
               (unless (eql delta +west+)
                 (setf (grid-ref grid coord) ’\.))
               targetl))

        (\] (let* ((targetr (2v+ coord delta))
                    (targetl (2v+ targetr +west+)))
               (unless (or (eql delta +east+)
                           (eql (grid-ref grid targetl) ’\.))
                 (move! grid targetl delta))
               (unless (or (eql delta +west+)
                           (eql (grid-ref grid targetr) ’\.))
                 (move! grid targetr delta))
               (setf (grid-ref grid targetl) ’[
                     (grid-ref grid targetr) ’])
               (unless (eql delta +east+)
                 (setf (grid-ref grid coord) ’\.))
               (unless (eql delta +west+)
                 (setf (grid-ref grid (2v+ coord +west+)) ’\.))
           targetr))))
    coord))

We need a function to find the initial location of the robot:

(defun find-robot (grid)
  (collect-first
   (choose
    (mapping (((coord item) (scan-grid grid)))
      (when (eql item ’@)
        coord)))))

And we need a function to score the grid.

(defun score-map (grid)
  (collect-sum
   (mapping (((coord item) (scan-grid grid)))
     (if (or (eql item ’O)
             (eql item ’[))
         (+ (* (row coord) 100) (column coord))
         0))))

It isn’t necessary for the solution, but it is helpful when debugging to have a function to print the grid.

(defun show-grid (grid)
  (dotimes (row (grid-height grid))
    (dotimes (column (grid-width grid))
      (format t "~a" (grid-ref grid (coord column row))))
    (format t "~%")))

To solve the puzzle, we use fold-left to drive the robot using the list of moves. This will side-effect the grid. When we are done moving, we score the grid.

(defun puzzle (input-file wide?)
  (multiple-value-bind (grid moves) (read-input input-file wide?)
    (fold-left (lambda (robot move)
                 (move! grid robot move))
               (find-robot grid)
               moves)
    (score-map grid)))

(defun part-1 ()
  (puzzle (input-pathname) nil))

(defun part-2 ()
  (puzzle (input-pathname) t))