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))

Advent of Code 2024: Day 14

For day 14, we are given the initial positions and velocities of a number of robots that walk a 101x103 grid. These are parsed with a regular expression:

(in-package "ADVENT2024/DAY14")

(defun read-input (input-file)
  (collect ’list
    (#M(lambda (line)
         (cl-ppcre:register-groups-bind ((#’parse-integer column) (#’parse-integer row)
                                         (#’parse-integer dx) (#’parse-integer dy))
             ("p=(\\d+),(\\d+)\\s+v=(-?\\d+),(-?\\d+)" line)
           (list (coord column row)
                 (coord dx dy))))
       (scan-file input-file #’read-line))))

The robots walk a grid linearly. They do not interact with each other, and they wrap when they cross the edge of the grid.

(defun step-n (width height coord velocity n)
  (2v-mod (2v+ coord (2v* n velocity)) (coord width height)))

For part 1, we are asked to multiply the number of robots in each quadrant after 100 steps in a 101 x 103 grid.

(defun quadrant (width height coord)
  (let ((half-width (floor width 2))
        (half-height (floor height 2)))
    (cond ((< (row coord) half-height)
           (cond ((< (column coord) half-width) 1)
                 ((> (column coord) half-width) 2)
                 (t nil)))
          ((> (row coord) half-height)
           (cond ((< (column coord) half-width) 3)
                 ((> (column coord) half-width) 4)
                 (t nil)))
          (t nil))))

(defparameter +grid-width+ 101)
(defparameter +grid-height+ 103)

(defun part-1 ()
  (let ((quadrants
          (#M(lambda (coord)
               (quadrant +grid-width+ +grid-height+ coord))
             (#M(lambda (robot)
                  (step-n +grid-width+ +grid-height+ (first robot) (second robot) 100))
                (scan 'list (read-input (input-pathname)))))))
    (* (collect-sum (#M(lambda (q) (if (eql q 1) 1 0)) quadrants))
       (collect-sum (#M(lambda (q) (if (eql q 2) 1 0)) quadrants))
       (collect-sum (#M(lambda (q) (if (eql q 3) 1 0)) quadrants))
       (collect-sum (#M(lambda (q) (if (eql q 4) 1 0)) quadrants)))))

We’re told that the robots form a picture of a Christmas tree after a certain number of steps. This was a bit tricky to figure out, but I figured that if the robots were clumped together in a picture, the number of empty rows and columns elsewhere would be maximized. Robots return to their starting point every 101 x 103 steps, so we only need to check the first 10403 steps.

(defun occupied-row? (locs row)
  (find row locs :test #’= :key #’row))

(defun occupied-column? (locs column)
  (find column locs :test #’= :key #’column))

(defun score (locs)
  (+ (collect-length
       (choose-if #’not
         (#Moccupied-row? (series locs) (scan-range :from 0 :below +grid-height+))))
     (collect-length
       (choose-if #’not
         (#Moccupied-column? (series locs) (scan-range :from 0 :below +grid-width+))))))

(defun part-2 ()
  (let ((robots (read-input (input-pathname))))
    (caar
     (sort
      (collect ’list
        (#M(lambda (n)
             (cons n (score (map ’list (lambda (robot)
                                         (step-n +grid-width+ +grid-height+ 
                                                 (first robot) (second robot) n))
                                 robots))))
           (scan-range :from 0 :below (* +grid-width+ +grid-height+))))
      #’> :key #’cdr))))

Advent of Code 2024: Day 13

For day 13, we're asked to find the solutions to some linear equations. We use the cl-ppcre library to parse the equations and then use Cramer’s rule to solve them.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY13")

;; Cramers Rule to solve Ax + By = M, Cx + Dy = N
;; x = (MD - BN) / (AD - BC)
;; y = (AN - MC) / (AD - BC)

(defun cramers-rule (A B C D M N)
  (let ((det (- (* A D) (* B C))))
    (if (= det 0)
        nil
        (values (/ (- (* M D) (* B N)) det)
                (/ (- (* A N) (* M C)) det)))))

The input is in blocks of three lines with a fourth blank line between them. We parse the input with a regular expressions and then apply cramers-rule to solve the equations. The conversion factor is a delta that is added to the coordinates of the target.

(defun puzzle (pathname &optional (conversion 0))
  (collect-sum
   (multiple-value-bind (line1 line2 line3 line4)
       (chunk 4 4 (catenate (scan-file pathname #’read-line)
                            (scan ’list ’("")))) ;; extra blank line at end
     (#M(lambda (line1 line2 line3)
          (cl-ppcre:register-groups-bind ((#’parse-integer ax)
                                          (#’parse-integer ay))
              ("Button A: X\\+(\\d+), Y\\+(\\d+)" line1)
            (cl-ppcre:register-groups-bind ((#’parse-integer bx)
                                            (#’parse-integer by))
                ("Button B: X\\+(\\d+), Y\\+(\\d+)" line2)
              (cl-ppcre:register-groups-bind ((#’parse-integer px)
                                              (#’parse-integer py))
                  ("Prize: X\\=(\\d+), Y\\=(\\d+)" line3)
                (multiple-value-bind (x y) (cramers-rule ax bx
                                                         ay by
                                                         (+ px conversion)
                                                         (+ py conversion))
                  (if (and x y (>= x 0) (>= y 0) (integerp x) (integerp y))
                      (+ (* x 3) y)
                      0))))))
        line1 line2 line3))))

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

(defun part-2 ()
  (puzzle (input-pathname) (expt 10 13)))

Advent of Code 2024: Day 12

For day 12, we’re back to a grid of characters. Each character labels a region on the grid.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY12")

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

We’re asked to find the area and perimeter of each region and the number of line segments in the perimeter. We use a flood-fill algorithm to find the area. If the flood-fill walks out of the region, we add 1 to the perimeter. The number of line segments in the perimeter is equal to the number of corners of the region, so we check for interior and exterior corners at each step.

(defun neighbors (coord)
   (list (coord-north coord)
         (coord-south coord)
         (coord-east coord)
         (coord-west coord)))

(defun flood-fill (grid visited seed-point)
  (let ((region-tag (grid-ref grid seed-point)))
    (flet ((in-region? (coord)
             (and (on-grid? grid coord)
                  (eql region-tag (grid-ref grid coord)))))
      (let itr ((points (list seed-point))
                (area 0)
                (perimeter 0)
                (corners 0))
        (if (null points)
            (values area perimeter corners)
            (let ((this-point (car points))
                  (rest-points (cdr points)))
              (cond ((not (in-region? this-point))
                     (itr rest-points area (1+ perimeter) corners))
                    ((grid-ref visited this-point)
                     (itr rest-points area perimeter corners))
                    (t
                     (setf (grid-ref visited this-point) t)
                     (itr (append rest-points (neighbors this-point))
                          (1+ area)
                          perimeter
                          (+ corners
                             (let ((n*  (in-region? (coord-north     this-point)))
                                   (ne* (in-region? (coord-northeast this-point)))
                                   (e*  (in-region? (coord-east      this-point)))
                                   (se* (in-region? (coord-southeast this-point)))
                                   (s*  (in-region? (coord-south     this-point)))
                                   (sw* (in-region? (coord-southwest this-point)))
                                   (w*  (in-region? (coord-west      this-point)))
                                   (nw* (in-region? (coord-northwest this-point))))
                               (+ ;; Concave corners
                                  (if (and n* e* (not ne*)) 1 0)
                                  (if (and e* s* (not se*)) 1 0)
                                  (if (and s* w* (not sw*)) 1 0)
                                  (if (and w* n* (not nw*)) 1 0)
                                  ;; Convex corners
                                  (if (and (not n*) (not e*)) 1 0)
                                  (if (and (not e*) (not s*)) 1 0)
                                  (if (and (not s*) (not w*)) 1 0)
                                  (if (and (not w*) (not n*)) 1 0))))))))))))))

To find seed points for regions, we scan the grid for points that are not visited. We rely on the series being pipelined so that the visited array is mutated as we process each region.

(defun scan-unvisited (visited)
  (declare (optimizable-series-function))
  (choose
   (mapping (((coord val) (scan-grid visited)))
     (and (null val) coord))))

To scan the regions, we flood fill the unvisited points.

(defun scan-regions (grid)
  (declare (optimizable-series-function 3))
  (let ((visited (make-array (array-dimensions grid) :initial-element nil)))
    (#3M(lambda (seed) (flood-fill grid visited seed))
     (scan-unvisited visited))))

To solve the puzzle, we scan the regions and apply the score function, summing the results.

(defun puzzle (grid score-function)  
  (collect-sum
   (mapping (((area perimeter segments) (scan-regions grid)))
     (funcall score-function area perimeter segments))))

Part 1 scores by multiplying the area by the perimeter.

(defun part-1 ()
  (puzzle (read-input (input-pathname))
          (lambda (area perimeter segments)
            (declare (ignore segments))
            (* area perimeter))))

Part 2 scores by multiplying the area by the number of segments in the perimeter.

(defun part-2 ()
  (puzzle (read-input (input-pathname))
          (lambda (area perimeter segments)
            (declare (ignore perimeter))
            (* area segments))))

Advent of Code 2024: Day 11

For day 11, we are given a list of stones inscribed with numbers.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY11")

(defun read-input (input-pathname)
  (collect ’list (scan-file input-pathname)))

On each blink (clock tick), we apply some rules to all the stones:

(defun digit-count (stone)
  (1+ (integer-log stone 10)))

(defun split-stone (stone)
  (let ((divisor (expt 10 (/ (digit-count stone) 2))))
    (multiple-value-list (floor stone divisor))))  ;; thanks Charlie McMackin

(defun apply-rules (stone)
  (cond ((zerop stone) (list 1))
        ((evenp (digit-count stone)) (split-stone stone))
        (t (list (* stone 2024)))))

The puzzle goes through the effort to ensure that you know that the stones are kept in order, but the fact is the order doesn’t matter at all. We can just keep track of the total number of stones of each value in a table. After each step, we collect all the stones with the same value and sum them up. Each stone will be represented by a stone-entry cons of the stone value and the number of stones with that value.

(defun coalesce (stone-alist)
  (let ((table (make-hash-table :test ’eql)))
    (dolist (stone-entry stone-alist table)
      (incf (gethash (car stone-entry) table 0) (cdr stone-entry)))))

So on each blink, we iterate over the table and apply the rules. Then we coalesce the results.

(defun blink (stone-table)
  (coalesce
   (multiple-value-bind (stone-values stone-counts) (scan-hash stone-table)
     (collect-append
      (#M(lambda (stone-value stone-count)
           (map ’list
               (lambda (new-stone) (cons new-stone stone-count))
               (apply-rules stone-value)))
         stone-values
         stone-counts)))))

The main loop is to simply call blink n times.

(defun initial-stone-table (initial-stones)
  (coalesce (map ’list (lambda (stone) (cons stone 1)) initial-stones)))

(defun blink-n (initial-stones n)
  (do ((stone-table (initial-stone-table initial-stones) (blink stone-table))
       (generation 0 (1+ generation)))
  ((>= generation n)
   (collect-sum (multiple-value-bind (stones counts) (scan-hash stone-table)
                   counts)))))

(defun part-1 ()
  (blink-n (read-input (input-pathname)) 25))

(defun part-2 ()
  (blink-n (read-input (input-pathname)) 75))

This problem took me a moment until I realized that the order of the stones didn’t matter. If you try to keep the stones in order, you end up with an exponential explosion of stones.

Advent of Code 2024: Day 10

For Day 10, we are given a topographic map as a grid of elevations.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY10")

(defun read-grid (input-pathname)
  (read-file-into-grid #’char->decimal input-pathname))

The trailheads are at elevation 0.

(defun find-trailheads (grid)
  (gethash 0 (invert-grid grid)))

At any elevation, we can take a step to a neighboring cell if it is at 1 unit higher elevation.

(defun take-step (grid location)
  (let ((target-elevation (1+ (grid-ref grid location))))
    (collect ’list
      (choose-if (lambda (loc)
                   (and (on-grid? grid loc)
                        (= (grid-ref grid loc) target-elevation)))
                 (scan ’list (list
                              (coord-north location)
                              (coord-east  location)
                              (coord-south location)
                              (coord-west  location)))))))

The trail-walker is a trail collector that takes a trailhead and does a breadth-first search to find the highest elevations reachable from that trailhead.

(defun trail-walker (grid)
  (lambda (trailhead)
    (collect-last
     (scan-fn ’list
              (lambda () (list trailhead))
              (lambda (frontiers)
                (remove-duplicates
                 (collect-append
                  (#Mtake-step (series grid) (scan frontiers)))
                 :test #’equal))
              #’null))))

A scorer is a curried function that takes a collector, then a grid, then a trailhead, and returns the score for that trailhead, which is the number of collected trails.

(defun scorer (collector)
  (lambda (grid)
    (let ((collect-trails (funcall collector grid)))
      (lambda (trailhead)
        (length (funcall collect-trails trailhead))))))

The puzzle takes a grid and a scorer, and sums the scores of the trailheads in the grid.

(defun puzzle (grid trailhead-scorer)
  (collect-sum
    (map-fn ’integer
            (funcall trailhead-scorer grid)
            (scan ’list (find-trailheads grid)))))

For the first part of the puzzle, we are to sum the scores of the trailheads using the trail-walker as the scorer. That is, for each trailhead, the number of highest points we can reach.

(defun part-1 ()
  (puzzle (read-grid (input-pathname)) (scorer #’trail-walker)))

For part two, we sum the number of paths to the highest points reachable from each trailhead. When we do the breadth-first search, we keep the history of the path we have taken.

(defun extend-path (grid path)
  (map ’list (lambda (step) (cons step path)) (take-step grid (car path))))

(defun trail-collector (grid)
  (lambda (trailhead)
    (collect-last
     (scan-fn ’list
              (lambda () (list (list trailhead)))
              (lambda (paths)
                (collect-append
                 (#Mextend-path
                    (series grid)
                    (scan ’list paths))))
              (lambda (paths)
                (every (lambda (path)
                         (= (length path) 11))
                       paths))))))

(defun part-2 ()
  (puzzle (read-grid (input-pathname)) (scorer #’trail-collector)))

Advent of Code 2024: Day 9

On Day 9 we are simulating defragging a disk. The input is a list of digits that alternate between a file size and a gap size. No file or gap is larger than 9 blocks.

The first part of the problem is to simply move the rightmost block that contains a file to the leftmost empty space. We repeat until there are no more empty spaces. Again, we could attempt to shoehorn this into a series approach, but it is straightforward to use an array to represent our disk and use side effects to simulate moving the blocks around.

Whenever you use an array, you’ll virtually always want to side effect the array contents, and you’ll virtually always iterate over the array. As a result, the do macro and its varaints such as dotimes will be useful interation constructs. The code will be definitely not be functional, but imperative in nature. There is just going to be state hanging out everywhere in this code.

The first thing we have to do is read the input:

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY9")

(defun read-input (input-file)
  (with-open-file (stream input-file :direction :input)
    (read-line stream nil nil)))

(defun read-layout (input-file)
  (let* ((line             (read-input input-file))
         (file-count       (/ (1+ (length line)) 2))
         (files            (make-simple-vector file-count))
         (free-block-count (1- file-count))
         (free-blocks      (make-simple-vector free-block-count)))
    (do ((input-index      0 (1+ input-index))
         (disk-loc         0 (+ disk-loc (char->decimal (schar line input-index))))
         (file-flag        t (not file-flag))
         (file-id          0 (if file-flag
                                 (1+ file-id)
                                 file-id))
         (free-block-index 0 (if file-flag
                                 free-block-index
                                 (1+ free-block-index))))
        ((>= input-index (length line)) (values files free-blocks))
      (if file-flag
          (setf (svref files file-id)
                (cons disk-loc (char->decimal (schar line input-index))))
          (setf (svref free-blocks free-block-index)
                (cons disk-loc (make-simple-vector (char->decimal (schar line input-index))
                                                   :initial-element nil)))))))

The main iteration alternates between reading a file block and a free block. The blocks are placed in a file array or a free-block array depending on the file-flag, which toggles on each pass through the loop. The disk-loc is updated with the size of the file or free block. File blocks are just the disk-loc consed to the file size, but free blocks are the disk-loc consed to an empty array that will be filled in later.

We’ll be required to compute a “checksum” of the disk, which will, for each block, the number of the block multplied by the file id of the file in the block. Since the files and the freelist are represented differently, we need a separate routine for each one and we’ll add them at the end.

(defun files-checksum (files)
  (collect-sum
    (#M(lambda (file-id)
         (let ((file-record (svref files file-id)))
           (collect-sum
             (#M(lambda (i)
                  (* file-id (+ (car file-record) i)))
              (scan-range :below (cdr file-record))))))
        (scan-range :below (length files)))))

The outer collect-sum loop iterates over each file summing the checksums. The inner collect-sum iterates over the blocks (stored in the cdr of the file record) in the file summing the product of the file-id and the offset of the block itself.

We handle freelist segments differently. They have an array into which we have moved file blocks, so we iterate over the array and multiply the file-id in the array (if there is one) by the freelist block offset and sum them:

(defun freelist-checksum (freelist)
  (collect-sum
   (#M(lambda (freelist-record)
        (let* ((segment-base (car freelist-record))
               (segment (cdr freelist-record)))
         (collect-sum
           (#M(lambda (offset-in-segment)
                (let ((file-id (or (svref segment offset-in-segment) 0)))
                  (* file-id (+ segment-base offset-in-segment))))
            (scan-range :below (length segment))))))
    (scan ’vector freelist))))

(defun filesystem-checksum (files freelist)
  (+ (files-checksum files)
     (freelist-checksum freelist)))

The two parts of the day’s puzzle involve two different strategies for “defragging” the disk. For part 1, we repeatedly move the rightmost file block to the leftmost free block. To find the rightmost occupied block, we iterate over the file list from right to left:

(defun source-block (files)
  (do ((file-id (1- (length files)) (1- file-id)))
      ((not (zerop (cdr (svref files file-id))))
       (values (+ (car (svref files file-id)) (cdr (svref files file-id)))
               (svref files file-id)
               file-id))))

To find the leftmost free block, we search the free blocks until we find one that is not fully occupied.

(defun target-block (freelist)
  (let* ((free-segment (find-if (lambda (segment)
                                  (position nil (cdr segment)))
                                freelist))
         (offset (position nil (cdr free-segment))))
    (values (+ (car free-segment) offset)
            (cdr free-segment)
            offset)))

These aren’t the most efficient because they forget the information from the previous search, but presumably a defragging process would be dominated by the disk reads and writes.

Once we have the source and target blocks, we move the source block to the target block:

(defun move-block! (files freelist)
  (multiple-value-bind (source-block source-record file-id) (source-block files)
    (multiple-value-bind (target-block target-segment target-offset) (target-block freelist)
      (when (< target-block source-block)
        (decf (cdr source-record))
        (setf (svref target-segment target-offset) file-id)
        t))))

We only move blocks to lower addresses and return NIL if we cannot move a block.

To defrag with this strategy, we just repeatedly call move-block! until it returns NIL:

(defun defrag1! (files freelist)
  (when (move-block! files freelist)
    (defrag1! files freelist)))

(defun puzzle (input-pathname defrag)
  (multiple-value-bind (files freelist) (read-layout input-pathname)
    (funcall defrag files freelist)
    (filesystem-checksum files freelist)))

(defun part-1 ()
  (puzzle (input-pathname) #’defrag1!))

Part 2 uses a different strategy to defrag the disk. Instead of blocks, we move entire files, and we move them to the leftmost block that they’ll fit. To find that leftmost block, we scan the freelist:

(defun defrag2-target (file freelist)
  (collect-first
   (choose-if
    (lambda (free-record)
      (and (< (car free-record) (car file))
           (<= (cdr file) (count nil (cdr free-record)))))
    (scan ’vector freelist))))

We iterate over the files from right to left:

(defun defrag2! (files freelist)
  (do ((file-id (1- (length files)) (- file-id 1)))
      ((zerop file-id))
    (let* ((file (svef files file-id))
           (target (defrag2-target file freelist)))
      (when target
        (let* ((start (position nil (cdr target)))
               (end (+ start (cdr file))))
          (fill (cdr target) file-id :start start :end end)
          (setf (cdr file) 0))))))

(defun part-2 ()
  (puzzle (input-pathname) #’defrag2!))

FOLD and NAMED-LET implementations

An anonymous reader requested an implementation of FOLD-LEFT, FOLD-RIGHT and NAMED-LET. Here they are:

https://github.com/jrm-code-project/fold
https://github.com/jrm-code-project/named-let

MIT license, developed and tested under SBCL, but should be portable. Implementation does not depend on tail recursion.

Advent of Code 2024: Day 8

Day 8 is another grid puzzle. We are given a map of antennas. Two antennas operate on the same frequency have the same ASCII character on the map. A “node” is a location on the map that is in line with two antennas of the same frequency and is twice as far from one antenna as the other. We are to count the nodes.

We can create an alist from antenna frequency to antenna locations by inverting the map:

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

(defun grid->antenna-list (grid)
  (hash-table-alist (invert-grid grid ’|.|)))

This solution makes use of first class functions. antinode-answer takes a function that produces an answer on one side of an antenna pair and applies it to the pair and swapped pair to produce answers on both sides.

(defun antinode-answer (antinode-half-answer)
  (lambda (grid left right)
    (append (funcall antinode-half-answer grid left right)
            (funcall antinode-half-answer grid right left))))

antinode-list takes a function that produces an answer for pair a single pair of antennas and maps it over all pairs of antennas on a frequency.

(defun antinode-list (antinode-answer)
  (lambda (grid node-list)
    (map-pairs (lambda (left right)
                 (funcall antinode-answer grid left right))
               node-list)))

All the antinodes can be obtained by invoking an antinode-list-generator over a set of node lists and appending the results.

(defun antinodes (antinode-list-generator)
  (lambda (grid node-list)
    (fold-left #’append nil
               (funcall antinode-list-generator grid node-list))))

So to solve the puzzle, we call an antinode generator on all the antennas.

(defun puzzle (grid antinode-generator)
  (length
   (remove-duplicates
    (fold-left (lambda (antinodes entry)
                 (append antinodes (funcall antinode-generator grid (cdr entry))))
               nil
               (grid->antenna-list grid))
    :test #’equal)))

In part 1, there is one node to the left and right of each pair, twice the distance from one antenna to the other.

(defun antinode (grid left right)
  (let* ((delta (2v- right left))
         (antinode (2v- left delta)))
    (when (on-grid? grid antinode)
      (list antinode))))

(defun part-1 ()
  (puzzle (read-grid (input-pathname))
          (antinodes (antinode-list (antinode-answer #’antinode)))))

For part two, the antinodes are at “resonant” points, i.e., spaced out equidistantly beyond the antenna pairs.

(defun resonant-antinodes (grid left right)
  (let* ((delta (2v- right left)))
    (do ((antinode left (2v- antinode delta))
         (answer ’() (cons antinode answer)))
        ((not (on-grid? grid antinode)) answer))))

(defun part-2 ()
  (puzzle (read-grid (input-pathname))
          (antinodes (antinode-list (antinode-answer #’resonant-antinodes)))))

Lisp was the first computer language to have first-class functions and lambda expressions.

Advent of Code 2024: Day 7

You don’t have to use named-lets for tail recursive loops. You can use them for any recursive function. Here is an example of a named let that computes the factorial of 5:

(let fact ((n 5))
  (if (= n 0)
      1
      (* n (fact (- n 1)))))

Day 7 is an unremarkable puzzle. On each line of input we are given a target number and some terms. We work on the terms from left to right and we can add the next term or multiply by it. We are to sum the target numbers which can be identified as a result of some combination of adding and multiplying.

;;; -*- Lisp -*-

(in-package "ADVENT2024/DAY7")

(defun can-satisfy? (target ops terms)
  (let recur ((accum (first terms))
              (terms (rest terms)))
       (cond ((and (> accum target)
                   (not (find-if #’zerop terms)))
              nil)
             ((consp terms)
              (find-if
               (lambda (op)
                 (recur (funcall op accum (first terms)) (rest terms)))
               ops))
             ((null terms) (= target accum))
             (t (error "Dotted list.")))))

(defun parse-integer-list (str)
  (map ’list #’parse-integer (str:split #\Space str :omit-nulls t)))

(defun parse-line (str)
  (let ((key+value (str:split #\: str)))
    (cons (parse-integer (first key+value))
          (parse-integer-list (second key+value)))))

(defun puzzle (ops)
  (collect-sum
    (let* ((equations
             (#Mparse-line
              (scan-file (input-pathname) #’read-line)))
           (satisfied (#M(lambda (equation)
                           (can-satisfy? (car equation) ops (cdr equation)))
                         equations)))
      (#Mcar (choose satisfied equations)))))

(defun part-1 ()
  (puzzle (list #’+ #’*)))

Part two allows us to concatenate the digits in addition to muliplying or adding.

(defun concatenate-digits (left right)
  (+ (* left (expt 10 (1+ (integer-log right 10))))
     right))

(defun part-2 ()
  (puzzle (list #’+ #’* #’concatenate-digits)))

Advent of Code 2024: Day 6

A named-lambda is a lambda expression that has a name bound to it only within the scope of the lambda expression. You can use the name to refer to the lambda expression from within the body of the lambda expression. This allows you to recursively call the lambda expression. Named-lambdas are easily created with a macro that expands into a labels form.

Named-lambdas are an alternative to using the Y operator to create recursive lambda expressions. Named-lambdas are a special form, so if you are uncomfortable with adding new special forms to the language, you’ll probably prefer to use the Y operator.

Recall that let expressions are just syntactic sugar for lambda expressions. If you expand a let expression using a named-lambda, you get a named-let expression. The name is bound to the lambda that binds the let variables. Invoking the name will re-invoke the let expression with different values for the bound variables.

Named lets take a moment to get used to, but once you get the hang of them, they are incredibly handy. They are especially useful when you use them for tail recursive loops. Here is an example where we use a named let to partition a list with a predicate:

(let next ((tail list)
           (yes ’())
           (no  ’()))
  (cond ((consp tail) 
         (if (predicate (car tail))
             (next (cdr tail) (cons (car tail) yes) no)
             (next (cdr tail) yes (cons (car tail) no))))
        ((null? tail) (values yes no))
        (t (error "Improper list."))))

When we invoke the name next, we re-invoke the let expression with the new values for the bound variables. In this example, the calls to next are in tail position, so the compiler turns them into jumps, making this a tail recursive loop.

The named-let syntax, with the name being the symbol before the bindings, is borrowed from MIT-Scheme. This syntax is easily implemented with a macro that expands into a labels form if the name is present, but expands into a cl:let if it is absent. You shadowing-import the let symbol into your package so that the macro will override the standard binding of let.

For day 6, we have a guard patrolling a warehouse. The guard moves in straight lines unless he encounters an obstacle, where he will turn clockwise 90 degrees. If he moves off the grid, he goes home for the evening.

First, we’ll read the grid and find the initial position of the guard:

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

(defun get-initial-position (grid)
  (let ((coord (collect-first
                (choose-if
                 (lambda (coord) (member (grid-ref grid coord) ’(^ < > v)))
                 (scan-grid-coords grid)))))
    (ocoord coord
           (ecase (grid-ref grid coord)
             (^ +north+)
             (> +east+)
             (v +south+)
             (< +west+)))))

In the second part of the problem, we’ll be allowed to place a single additional obstacle in the grid. patrol-step attempts to move the guard one step forward, and turns him clockwise if he cannot move forward. obstacle-coord is the additional obstacle or nil:

(defun patrol-step (grid obstacle-coord oriented-position)
  (let ((next-ocoord (ocoord-advance oriented-position)))
    (cond ((not (on-grid? grid (ocoord-coord next-ocoord))) nil)
          ((or (eq (grid-ref grid (ocoord-coord next-ocoord)) ’|#|)
               (equal (ocoord-coord next-ocoord) obstacle-coord))
           (ocoord-cw oriented-position))
          (t next-ocoord))))

patrol places the guard at his initial position and repeatedly calls patrol-step until the guard either walks off the grid or returns to an ocoord he has visited before (with the same orientation). We keep the history of visited ocoords in two ways: as a list and a hash table. The list gives us the history in order, while the hash table allows us to quickly check if we have visited an ocoord before (otherwise we’d have an O(n^2) algorithm). If the guard walks off the grid, we return the history list. If the guard returns to a previously visited ocoord, we return the symbol :loop. Note the use of a named-let to loop the patrol steps.

(defun patrol (grid obstacle-coord start-opos)
  (let ((history-hash (make-hash-table :test ’equal)))
    (setf (gethash start-opos history-hash) t)
    (let iter ((opos start-opos)
               (history (list start-opos)))
      (let ((next (patrol-step grid obstacle-coord opos)))
        (cond ((null next) history)
              ((gethash next history-hash nil) :loop)
              (t (setf (gethash next history-hash) t)
                 (iter next (cons next history))))))))

For part 1, we simply call patrol with the initial position and nil as the obstacle:

(defun unique-cells (history)
  (length (remove-duplicates (map ’list #’ocoord-coord history) :test #’equal)))

(defun part-1 ()
  (let* ((grid (read-input (input-pathname)))
         (initial-position (get-initial-position grid)))
    (unique-cells (patrol grid nil initial-position))))

For part 2, we iterate over the cells in the paths and see what happens if we place an obstacle there. We accumulate the locations that result in a loop:

(defun part-2 ()
  (let* ((grid (read-input (input-pathname)))
         (initial-position (get-initial-position grid))
         (unmodified-path (patrol grid nil initial-position))
         (answer nil))
    (dolist (obstacle (remove-duplicates (map ’list #’ocoord-coord unmodified-path) :test #’equal)
                      (length (remove-duplicates answer :test #’equal)))
      (unless (and obstacle
                   (equal obstacle (ocoord-coord initial-position)))
        (when (eq (patrol grid obstacle initial-position) :loop)
          (pushnew obstacle answer :test #’equal))))))

Advent of Code 2024: Day 5

For day 5, the input comes in two parts: There are rules of the form n|m, where n and m are numbers, and there are “updates” which are lists of numbers separated by commas. The rules are used to determine which updates are valid. An update is valid if it passes all applicable rules. A rule is applicable if the two numbers in the rule appear in the update. An update passes an applicable rule if the two numbers in the rule appear in the update in the same order as they appear in the rule.

To read the input, we read the lines and collect them into two lists. The rule list is all the lines that contain a pipe character, and the updates list is all the lines that contain a comma:

(defun read-input (input-file)
  (let ((lines (scan-file input-file #'read-line)))
    (let ((is-rule (#M(lambda (line) (find #\| line)) lines))
          (is-update (#M(lambda (line) (find #\, line)) lines)))
      (values (collect ’list (#M(lambda (rule)
                                  (map ’list #’parse-integer (str:split #\| rule)))
                                (choose is-rule lines)))
              (collect ’list (#M(lambda (update)
                                  (map ’list #’parse-integer (str:split #\, update)))
                                (choose is-update lines)))))))

To test a rule, we find the location of the two numbers in the update and check that they are in the same order as they appear in the rule. If either number is not found, the rule is not applicable and trivially passes.

(defun test-rule (rule update)
  (let ((left-position (position (first rule) update))
        (right-position (position (second rule) update)))
    (or (null left-position)
        (null right-position)
        (< left-position right-position))))

(defun test-rules (rules update)
  (collect-and
   (#Mtest-rule
    (scan ’list rules)
    (series update))))

Part 1 is to sum the middle numbers of all the updates that pass all the rules:

(defun middle-number (list)
  (elt list (/ (1- (length list)) 2)))

(defun part-1 ()
  (multiple-value-bind (rules updates) (read-input (input-pathname))
    (collect-sum
     (#Mmiddle-number
      (choose-if
       (lambda (update) (test-rules rules update))
       (scan ’list updates))))))

For part 2, we select the updates that fail the rules. We repair the update by sorting it using the rules as a sort predicate, then we sum the middle numbers of the repaired updates:

(defun sort-using-rules (rules list)
  (sort list (lambda (left right)
               (find (list left right) rules :test #’equal))))

(defun part-2 ()
  (multiple-value-bind (rules updates) (read-input (input-pathname))
    (collect-sum
     (#Mmiddle-number
      (#M(lambda (update) (sort-using-rules rules update))
       (choose-if
        (lambda (update) (not (test-rules rules update)))
        (scan ’list updates)))))))

Advent of Code 2024: Day 4

Day 4 part 1 is your standard word search. First we read the grid of letters:

(defun read-input (input-pathname)
  (read-file-into-grid
    (char-interner #'char-upcase (find-package "ADVENT2024/DAY4"))
    input-pathname))

A “trace” is a row, column, or diagonal of letters. To search a trace for the word, we examine each suffix of the trace to see if starts with the word. We also check the reverse of the word:

(defun search-trace (trace target)
  (let ((rev (reverse target)))
    (collect-sum
     (#M(lambda (suffix)
          (if (or (starts-with-subseq target suffix)
                  (starts-with-subseq rev suffix))
              1
              0))
        (scan-suffixes trace)))))

Then we search all the traces:

(defun search-trace-list (trace-list target)
  (collect-sum
   (#M(lambda (trace)
        (search-trace trace target))
    (scan 'list trace-list))))

(defun search-grid (grid target)
  (collect-sum
   (#M(lambda (get-trace-list)
        (search-trace-list (funcall get-trace-list grid) target))
      (scan ’list
         (list (lambda (grid) (collect ’list (scan-rows grid)))
               (lambda (grid) (collect ’list (scan-columns grid)))
               (lambda (grid) (collect ’list (scan-falling-diagonals grid)))
               (lambda (grid) (collect ’list (scan-rising-diagonals grid))))))))

(defun part-1 ()
  (search-grid (read-input (input-pathname)) #(X M A S)))

Note that since scan-rows etc. and collect are macros, so we cannot pass them as first class functions. Instead we pass lambdas that call them so that the full macro expression is visible to the compiler.

For part 2, we are searching for Xs of “MAS” in the grid. We search for As, then check for M and S in the diagonals.

m-s1? is a helper function that checks if a pair of coords contains an M and an S.

(defun m-s1? (grid coord1 coord2)
  (and (on-grid? grid coord1)
       (on-grid? grid coord2)
       (eql (grid-ref grid coord1) 'M)
       (eql (grid-ref grid coord2) 'S)))

m-s? checks if a pair of coords contains an M and an S in any order.

(defun m-s? (grid coord1 coord2)
  (or (m-s1? grid coord1 coord2)
      (m-s1? grid coord2 coord1)))

x-mas? checks whether an A is surrounded by an M and an S.

(defun x-mas? (grid coord)
  (and (on-grid? grid coord)
       (eql (grid-ref grid coord) 'A)
       (and (m-s? grid (coord-northwest coord) (coord-southeast coord))
            (m-s? grid (coord-northeast coord) (coord-southwest coord)))))

Then we just count the occurrances:

(defun search-x-mas (grid)
  (collect-sum
   (#M(lambda (coord)
        (if (x-mas? grid coord)
            1
            0))
      (scan-grid-coords grid))))

(defun part-2 ()
  (search-x-mas (read-input (input-pathname))))

Advent of Code 2024: Day 3

For Day 3, we are given a “corrupted” block of memory as a string. We are to find the “uncorrupted instructions” in the block and emulate them.

For this problem, we don’t attempt to force things into the series paradigm. The cl-ppcre library provides a bunch of functions for working with regular expressions, and the do-register-groups macro is ideal for this problem. It iterates over all the matches of a regular expression, binding submatches to some variables, with some optional processing of the submatch. (If the cl-ppcre library offered a function that returned a series of matches, we could use that, but it offers a do macro.)

First, we read the input:

(defun read-input (input-pathname)
  (read-file-into-string input-pathname))

Next, we define a regular expression to match the instructions:

(defparameter *mul-instruction* "(mul\\((\\d{1,3}),(\\d{1,3})\\))")

Now we just iterate over all the matches:

(defun part-1 ()
  (let ((answer 0))
    (cl-ppcre:do-register-groups (whole (#’parse-integer left) (#’parse-integer right))
        (*mul-instruction* (read-input (input-pathname)))
      (declare (ignore whole))
      (incf answer (* left right)))
    answer))

do-register-groups is an example of a macro where the parenthesized subexpressions do not indicate function calls. The first parenthesized subgroup is a variable list, and within the variable list, a parenthesized subgroup indicates a transformer to be applied before binding the variable. So in this case, we are binding the variables whole, left, and right, and we run the matching subgroup through parse-integer before binding the left and right variables.

The second parenthesized subgroup is a list of the regular expression to match and the string to match within. After these irregular parenthesized subgroups, the remaining is a body of code that is executed for each match.

In the body of the code, we ignore the whole variable (which is the whole match) and increment the answer by the product of the left and right variables. As is usual for a do macro, we transport the data out of the loop by side effecting a lexically scoped variable.

For part 2, we have additional instructions to emulate. Our loop will now have some state to it, and we will side effect the state as we iterate over the matches. We can just extend the regular expression and add a cond to the body of the do-register-groups to handle the new instructions. As we iterate over the matches, we side effect the emulation state:

(defparameter *do-mul-instruction* "(do\\(\\))|(don’t\\(\\))|(mul\\((\\d{1,3}),(\\d{1,3})\\))")

(defun part-2 ()
  (let ((answer 0)
        (on t))
    (cl-ppcre:do-register-groups (turn-on turn-off whole (#’parse-integer left) (#’parse-integer right))
        (*do-mul-instruction* (read-input (input-pathname)))
      (declare (ignore whole))
      (cond (turn-on (setq on t))
            (turn-off (setq on nil))
            (on (incf answer (* left right)))
            (t nil)))
    answer))

Strictly speaking, we don’t need to use side effects. We could rework this to be purely functional, but this seems unnatural. Yes, there is a bit of cognitive overhead in remembering that there is a state variable that determines whether or not we are executing an instruction, but the code is quite understandable.

“Do” macros usually need some side effects, but we can localize the side effects by using a let to lexically bind the state variables and then side effecting them from within the loop. This is an effective compromise between the functional and imperative programming paradigms.

Advent of Code 2024: Day 2

For Day 2 in the Advent of Code, we are given a file where each line in the file contains a list of integers separated by spaces. We will be performing some manipulations on these lists.

First, we need to read the file. We make a function to read a line as a string, then read the integers from the string and collect the result into a list.

(defun read-levels (stream eof-error-p eof-value)
  (let ((line (read-line stream eof-error-p eof-value)))
    (if (eq line eof-value)
        eof-value
        (with-input-from-string (stream line)
          (collect ’list (scan-stream stream))))))

We use this function to read the entire file into a list of lists of integers.

(defun read-input (input-pathname)
  (collect ’list (scan-file input-pathname #’read-levels)))

We are concerned with the deltas between adjacent elements in a series of integers. We make a function to calculate the deltas. This will be an optimizable-series-function because it returns a series of deltas. We declare the argument to be an “off-line” input series as well. This code will be transformed into the equivalent loop code where we consume the deltas.

chunk is a series function that takes a series and produces n series of chunks that are offset by a specified amount. We produce chunks of size 2, offset by 1. This returns two series, the left number of each pair of numbers and the right number of each pair of numbers. By mapping #’- over these series, we get the series of deltas between adjacent numbers.

(defun deltas (series)
  (declare (optimizable-series-function)
           (off-line-port series))
  (multiple-value-bind (left right) (chunk 2 1 series)
    (#M- right left)))

As per the puzzle, a series of deltas is considered “safe” if it is strictly ascending or descending, and each step by which it ascends or descends is between 1 and 3 inclusive. We get the series of deltas, map #’plusp to get a series of booleans indicating whether each delta is positive, and collect-and on the series of booleans. Likewise with #’minusp for descending. Finally, we create a series of booleans indicating whether the absolute value of the delta is <= 3 and collect-and this as well. Whether the deltas are considered “safe” is just a boolean operation on these three boolean values:

(defun safe-levels? (list)
  (let ((deltas (deltas (scan list))))
    (let ((ascending (collect-and (#Mplusp deltas)))
          (descending (collect-and (#Mminusp deltas)))
          (small (collect-and (#M<= (Mmabs deltas) (series 3)))))
      (and small
           (or ascending descending)))))

The first part of the puzzle asks us to count the number of lines considered “safe”:

(defun part-1 ()
  (count-if #’safe-levels? (read-input (input-pathname))))

The second part of the puzzle relaxes the safety restriction by saying that you are allowed to ‘dampen’ the list by removing a single outlier before checking for safety.

(defun safe-dampened-levels? (levels)
  (find-if #’safe-levels? (remove-one-element levels)))

(defun part-2 ()
  (count-if #’safe-dampened-levels? (read-input (input-pathname))))

Advent of Code 2024: Day 1

Half the problem of solving an Advent of Code puzzle is dealing with the puzzle input. It is generally in some ad hoc format that requires a bespoke parser. There are a few approches you can take.

• Read the input as a string and directly call string manipulation functions to extract the data.
• Read the input as a string and use regular expressions to extract the data.
• Use the lisp reader to read the input as a lisp data structure. This requires that the input looks like lisp objects.
• Tweak the Lisp reader to read the data in a custom format. This works if the input looks a lot like lisp objects.

For Day 1, the input is two columns of numbers. If we just scan the file with the lisp reader, we'll get a single list of numbers. We can convert this into two lists with the series chunk function:

(defun read-input (input-pathname)
  (multiple-value-bind (left-column right-column)
      (chunk 2 2 (scan-file input-pathname))
    (values (collect ’list left-column)
            (collect ’list right-column))))

For part 1 of the puzzle, we sort both columns and then walk through them in parallel finding the absolute difference between the columns and summing that.

(defun part-1 ()
  (multiple-value-bind (left-column right-column)
      (read-input (input-pathname))
    (collect-sum
     (#Mabs
      (#M-
       (scan (sort left-column #’<))
       (scan (sort right-column #’<)))))))

For part 2, we look at each number in the left column and multiply it by how many times it appears in the right column. We sum these quantities.

(defun part-2 ()
  (multiple-value-bind (left-column right-column)
      (read-input (input-pathname))
    (collect-sum
     (#M(lambda (item) (* item (count item right-column)))
        (scan left-column)))))

These examples show how we can use series and built-in sequence functions to eliminate loops.

Advent of Code 2024: Day 0

I wanted to write some blog posts, but I was short of material. For the fun of it, I’ve decided to write a series of posts about solving the 2024 Advent of Code problems in Common Lisp. I see that other people were doing this in real time, but it is too late for that. Besides, I didn’t want the stress of trying to solve the problems as part of a competition. I wanted to take my time and focus on code quality rather than on how fast I can write it.

I noticed that some programmers were less experienced in Common Lisp. They tended to code up solutions that used low-level Common Lisp operations instead of using one of Common Lisp’s powerful sequence operations. For example, they might use a loop to iterate over a list and incf a counter instead of just using a call to count. I want to show how to effectively use the rich set of Common Lisp library functions to write concise, readable, and efficient code.

I’m trying to decide what I think of the series package that provides a more functional approach to iteration without sacrificing performance. For a lot of iterations, it is easy to write series code, but it for other iterations it isn’t so obvious. I wanted a little practice in using series and seeing its limitations.

Conventions

One of the features of Common Lisp is that you can tailor the language to fit the problem space. The first step in solving the problem suite is to configure the language. Since I wanted to explore using the series package, I set up my Lisp so that series was available in all the packages. I also installed the alexandria library, which is a collection of utilities that flesh out the Common Lisp standard library with some obvious “missing” functions.

The series package includes an optional #M reader macro that gives you a shorthand for writing mapping expressions. I added the “named” let syntax which attaches a name to the binding lambda of a let expression allowing you to invoke the reinvoke the let as a recursive function. The default delarations were set to ensure that the compiler could would generate tail recursive code. Tail recursion coupled with named-let is a powerful iteration facility.

I set up the directory structure to have a subdirectory for each day. Each problem in the entire Advent of Code could fit in its own solution.lisp file, so each subdirectory had files input.txt and solution.lisp, and usually sample-input.txt and maybe one or more sample-input-n.txt

The parent directory had an advent2024.asd file, a package.lisp file that defined all the packages, an initialize.lisp file that customized Common Lisp and installed some bootstrap values in each package, and a misc.lisp file that contained some common definitions that were exported to all the packages.

I set up my Lisp to have a separate package for each day. The package definition file contained 25 package definitions, each one virtually identical, e.g.:

(defpackage "ADVENT2024/DAY16"
  (:shadow "VALIDATE")
  (:import-from "ALEXANDRIA"
                "FLATTEN"
                "HASH-TABLE-ALIST"
                "HASH-TABLE-KEYS"
                "HASH-TABLE-VALUES"
                "LENGTH="
                "MAPPEND"
                "MAP-PERMUTATIONS"
                "MAP-PRODUCT"
                "READ-FILE-INTO-STRING"
                "STARTS-WITH-SUBSTRING"
                )
  (:shadowing-import-from "NAMED-LET" "LET")
  (:shadowing-import-from "SERIES"
                          "DEFUN"
                          "FUNCALL"
                          "LET*"
                          "MULTIPLE-VALUE-BIND"
                          )
  (:export "PART-1" "PART-2" "+SOLUTION-1+" "+SOLUTION-2+" "VALIDATE")
  (:use "ADVENT2024" "COMMON-LISP" "FOLD" "FUNCTION" "NAMED-LET" "SERIES"))

This basically set up Lisp to have series available, and imported a few symbols from alexandria.

Each day’s puzzle has two parts, so each package exports the symbols PART-1 and PART-2 to be defined as zero argument functions that compute and return the solution to the respective parts. The symbols +SOLUTION-1+ and +SOLUTION-2+ are defined as defparameter values. The initialization function installs a validate function checks that (part-1) returns +SOLUTION-1+ and (part-2) returns +SOLUTION-2+ in each package.

misc.lisp

The misc.lisp file contains code that is common to more than one puzzle.

The grid abstraction

The problem space of many of the puzzles is two dimensional, and it is natural to use a two-dimensional lisp array for the representation. I enhance this with a lightweight abstraction called a grid.

A grid is adressed by a coord, which is an ordered pair of column and row. These are simply the car and cdr of a cons cell. The functions that construct and select from a coord are all given compiler-macro definitions. In the 99% of the cases where you simply call the constructor or selector, the compiler macro will expand the code. In the 1% case, where you pass the constructor or selector as a first-class function, the function definition is passed.

(deftype grid-index ()
  ‘(integer ,(- array-dimension-limit) (,array-dimension-limit)))

(deftype coord ()
  ’(cons (grid-index) (grid-index)))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun coord (column row)
  (check-type column grid-index)
  (check-type row grid-index)
  (cons column row))
)

(define-compiler-macro coord (column row)
  ‘(cons ,column ,row))

(defun column (coord)
  (check-type coord coord)
  (car coord))

(define-compiler-macro column (coord)
  ‘(car ,coord ))

(defun row (coord)
  (check-type coord coord)
  (cdr coord))

(define-compiler-macro row (coord)
  ‘(cdr ,coord))

(defun scan-coords (row-count col-count)
  (declare (optimizable-series-function))
  (multiple-value-bind (rows cols)
      (map-fn ’(values grid-index grid-index)
              #’floor
              (scan-range :below (* row-count col-count))
              (series col-count))
    (declare (type (series grid-index) rows cols))
    (map-fn ’coord #’coord cols rows)))

A grid is just a two-dimensional array of atoms:

(deftype grid () ‘(array atom 2))

(defun make-grid (height width &rest keys)
  (apply #’make-array (list height width) keys))

(defun row-list->grid (row-list)
  (make-grid (length row-list) (length (first row-list)) :initial-contents row-list))

(defun grid-height (grid)
  (check-type grid grid)
  (array-dimension grid 0))

(define-compiler-macro grid-height (grid)
  ‘(array-dimension ,grid 0))

(defun grid-width (grid)
  (check-type grid grid)
  (array-dimension grid 1))

(define-compiler-macro grid-width (grid)
  ‘(array-dimension ,grid 1))

A coord is on a grid if it is within the bounds of the grid:

(defun on-grid? (grid coord)
  (and (>= (column coord) 0)
       (< (column coord) (grid-width grid))
       (>= (row coord) 0)
       (< (row coord) (grid-height grid))))

You may want to check if the coord is on the grid before calling grid-ref.

(defun grid-ref (grid coord)
  (check-type grid grid)
  (check-type coord coord)
  (aref grid (row coord) (column coord)))

(define-compiler-macro grid-ref (grid coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (aref ,grid (row ,coord-var) (column ,coord-var)))))

(defsetf grid-ref (grid coord) (value)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (setf (aref ,grid (row ,coord-var) (column ,coord-var)) ,value))))

(defun scan-grid-coords (grid)
  (declare (optimizable-series-function))
  (scan-coords (grid-height grid) (grid-width grid)))

(defun scan-grid (grid)
  (declare (optimizable-series-function 2))
  (#2m(lambda (grid coord)
        (values coord (grid-ref grid coord)))
      (series grid)
      (scan-coords (grid-height grid) (grid-width grid))))

You can invert a grid. This will give you a hash table that maps the atoms in the grid to a list of their coords.

(defun invert-grid (grid &optional initial-value)
  (if initial-value
      (multiple-value-bind (coords vals) (scan-grid grid)
        (collect-hash-push-except vals coords (list initial-value)))
      (multiple-value-bind (coords vals) (scan-grid grid)
        (collect-hash-push vals coords))))

You can extract a row, column, or diagonal from a grid:

(defun grid-row (grid row-number)
  (check-type grid grid)
  (make-array (list (grid-width grid))
              :displaced-to grid
              :displaced-index-offset (array-row-major-index grid row-number 0)))

(defun grid-column (grid columm-number)
  (check-type grid grid)
  (let ((answer (make-array (grid-height grid))))
    (dotimes (row (grid-height grid) answer)
      (setf (svref answer row)
            (grid-ref grid (coord columm-number row))))))

(defun grid-falling-diagonal (grid diagonal-number)
  (check-type grid grid)
  (let ((start-column (if (minusp diagonal-number)
                          0
                          diagonal-number))
        (start-row (if (minusp diagonal-number)
                       (- diagonal-number)
                       0)))
    (let ((limit (min (- (grid-width grid) start-column)
                      (- (grid-height grid) start-row))))
      (let ((answer (make-array (list limit))))
        (do ((row    start-row    (+ row 1))
             (column start-column (+ column 1))
             (index 0 (+ index 1)))
            ((>= index limit) answer)
          (setf (svref answer index)
                (grid-ref grid (coord column row))))))))

(defun grid-rising-diagonal (grid diagonal-number)
  (check-type grid grid)
  (let ((start-column (if (minusp diagonal-number)
                          (- diagonal-number)
                          0))
        (start-row (if (minusp diagonal-number)
                       (1- (grid-height grid))
                       (- (grid-height grid) diagonal-number 1))))
    (let ((limit (min (- (grid-width grid) start-column)
                      (1+ start-row))))
      (let ((answer (make-array (list limit))))
        (do ((row    start-row    (- row 1))
             (column start-column (+ column 1))
             (index 0 (+ index 1)))
            ((>= index limit) answer)
          (setf (svref answer index)
                (grid-ref grid (coord column row))))))))

Given a grid, you can get the series of rows, columns, or diagonals:

(defun scan-rows (grid)
  (declare (optimizable-series-function))
  (map-fn ’vector #’grid-row (series grid) (scan-range :below (grid-height grid))))

(defun scan-columns (grid)
  (declare (optimizable-series-function))
  (map-fn ’vector #’grid-column (series grid) (scan-range :below (grid-width grid))))

(defun scan-falling-diagonals (grid)
  (declare (optimizable-series-function))
  (map-fn ’vector
          #’grid-falling-diagonal
          (series grid)
          (scan-range :from (1+ (- (grid-height grid))) :below (grid-width grid))))

(defun scan-rising-diagonals (grid)
  (declare (optimizable-series-function))
  (map-fn ’vector
          #’grid-rising-diagonal
          (series grid)
          (scan-range :from (- 1 (grid-width grid)) :below (grid-height grid))))

An orientation is a unit coord.

(deftype unit ()
  ‘(integer -1 1))

(deftype orientation ()
  ’(cons (unit) (unit)))

(defun unit-vector (column row)
  (check-type column unit)
  (check-type row unit)
  (cons column row))

(defparameter +north+ (unit-vector 0 -1))
(defparameter +northeast+ (unit-vector 1 -1))
(defparameter +east+  (unit-vector 1 0))
(defparameter +southeast+ (unit-vector 1 1))
(defparameter +south+ (unit-vector 0 1))
(defparameter +southwest+ (unit-vector -1 1))
(defparameter +west+  (unit-vector -1 0))
(defparameter +northwest+ (unit-vector -1 -1))

You can do 2d-vector arithmetic on a coord

(defun 2v+ (left right)
  (coord (+ (column left) (column right))
         (+ (row left) (row right))))

(defun 2v- (left right)
  (coord (- (column left) (column right))
         (- (row left) (row right))))

Given a coord, you can get the coord of the adjacent cell in a given orientation. Note that the new coord might not be on the grid if you’re at the edge.

(defun coord-north (coord)
  (check-type coord coord)
  (2v+ coord +north+))

(define-compiler-macro coord-north (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (column ,coord-var) (1- (row ,coord-var))))))

(defun coord-northeast (coord)
  (check-type coord coord)
  (2v+ coord +northeast+))

(define-compiler-macro coord-northeast (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (1+ (column ,coord-var)) (1- (row ,coord-var))))))

(defun coord-east (coord)
  (check-type coord coord)
  (2v+ coord +east+))

(define-compiler-macro coord-east (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (1+ (column ,coord-var)) (row ,coord-var)))))

(defun coord-southeast (coord)
  (check-type coord coord)
  (2v+ coord +southeast+))

(define-compiler-macro coord-southeast (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (1+ (column ,coord-var)) (1+ (row ,coord-var))))))

(defun coord-south (coord)
  (check-type coord coord)
  (2v+ coord +south+))

(define-compiler-macro coord-south (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (column ,coord-var) (1+ (row ,coord-var))))))

(defun coord-southwest (coord)
  (check-type coord coord)
  (2v+ coord +southwest+))

(define-compiler-macro coord-southwest (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (1- (column ,coord-var)) (1+ (row ,coord-var))))))

(defun coord-west (coord)
  (check-type coord coord)
  (2v+ coord +west+))

(define-compiler-macro coord-west (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (1- (column ,coord-var)) (row ,coord-var)))))

(defun coord-northwest (coord)
  (check-type coord coord)
  (2v+ coord +northwest+))

(define-compiler-macro coord-northwest (coord)
  (let ((coord-var (gensym "COORD-")))
    ‘(let ((,coord-var ,coord))
       (coord (1- (column ,coord-var)) (1- (row ,coord-var))))))

An ocoord is a coord that has a direction associated with it. It is a coord plus an orientation.

(deftype ocoord ()
  ’(cons coord orientation))

(defun ocoord (coord orientation)
  (check-type coord coord)
  (check-type orientation orientation)
  (cons coord orientation))

(define-compiler-macro ocoord (coord orientation)
  ‘(cons ,coord ,orientation))

(defun ocoord-coord (ocoord)
  (check-type ocoord ocoord)
  (car ocoord))

(define-compiler-macro ocoord-coord (ocoord)
  ‘(car ,ocoord))

(defun ocoord-orientation (ocoord)
  (check-type ocoord ocoord)
  (cdr ocoord))

(define-compiler-macro ocoord-orientation (ocoord)
  ‘(cdr ,ocoord))

The point of an ocoord is to be able to take a step forward in the direction of the orientation, or to turn clockwise or counterclockwise.

(defun ocoord-advance (ocoord)
  (check-type ocoord ocoord)
  (ocoord (2v+ (ocoord-coord ocoord) (ocoord-orientation ocoord))
          (ocoord-orientation ocoord)))

(define-compiler-macro ocoord-advance (ocoord)
  (let ((ocoord-var (gensym "OCOORD-")))
    ‘(let ((,ocoord-var ,ocoord))
       (ocoord (2v+ (ocoord-coord ,ocoord-var) (ocoord-orientation ,ocoord-var))
               (ocoord-orientation ,ocoord-var)))))

(defun ocoord-cw (ocoord)
  (check-type ocoord ocoord)
  (ocoord (ocoord-coord ocoord)
          (cond ((equal (ocoord-orientation ocoord) +north+) +east+)
                ((equal (ocoord-orientation ocoord) +east+) +south+)
                ((equal (ocoord-orientation ocoord) +south+) +west+)
                ((equal (ocoord-orientation ocoord) +west+) +north+))))

(defun ocoord-ccw (ocoord)
  (check-type ocoord ocoord)
  (ocoord (ocoord-coord ocoord)
          (cond ((equal (ocoord-orientation ocoord) +north+) +west+)
                ((equal (ocoord-orientation ocoord) +east+) +north+)
                ((equal (ocoord-orientation ocoord) +south+) +east+)
                ((equal (ocoord-orientation ocoord) +west+) +south+))))

The grid input to many of the puzzles is presented as “ASCII art” characters in a file. For example, the input might look like this:

....#.....
.........#
..........
..#.......
.......#..
..........
.#..^.....
........#.
#.........
......#...

To read this into a grid, we’ll need a function that converts a string into a list of atoms. We’ll need a function that converts a char to an atom:

(defun string-mapper (char-fn)
  "Returns a function that maps strings to lists."
  (lambda (line)
    (collect ’list
      (map-fn ’t
        char-fn
        (scan ’string line)))))

We can use this to read the input file into a grid:

(defun read-file-into-grid (char-fn filename)
  "Returns the contents of the file as a two-dimensional array."
  (row-list->grid
   (collect ’list
     (map-fn ’list
             (string-mapper char-fn)
             (scan-file filename #’read-line)))))

char-fn is called on each character in the file. If it is #’identity, then the grid will be a grid of characters. However, we usually want a grid of atoms, so we supply a function that converts a character to an atom.

(defun char->decimal (char)
  (- (char-code char) (char-code #\0)))

(defun char-interner (char-folder package)
  (lambda (char)
    (if (digit-char-p char)
        (char->decimal char)
        (intern (string (funcall char-folder char)) package))))

We can use this to read the input file into a grid:

;; Case folding
(read-file-into-grid (char-interner #’char-upcase *package*) "input.txt")

;; Case preserving
(read-file-into-grid (char-interner #’identity *package*) "input.txt")

Other miscellaneous functions

advent-pathname converts a relative pathname to an absolute pathname in the advent2024 directory. advent-pathname is used to find the input files.

(defun advent-pathname (pathname)
  (merge-pathnames pathname
                   (asdf/system:system-source-directory "advent2024")))

cartesian-product-list takes a list of lists and returns a list of lists that are the cartesian product of the input lists. For example, (cartesian-product-list ’((1 2) (3 4))) returns ((1 3) (1 4) (2 3) (2 4)).

(defun map-cons (car cdrs)
  (map ’list (lambda (cdr) (cons car cdr)) cdrs))

(defun cartesian-product (&rest lists)
  (cartesian-product-list lists))

(defun cartesian-product-list (lists)
  (fold-left (lambda (tails terms)
               (mappend (lambda (term)
                          (map-cons term tails))
                        terms))
             (list nil)
             (reverse lists)))

integer-log is used to find the number of digits an integer has in a given base.

(defun integer-log (n base)
  "Returns two values, the integer-log of <n> in <base>, and the leftmost digit
in <base>."
  (if (< n base)
      (values 0 n)
      (multiple-value-bind (ilog l) (integer-log n (* base base))
        (if (< l base)
            (values (* ilog 2) l)
            (values (+ (* ilog 2) 1) (/ l base))))))

Miscellaneous list functions

I gave the miscellaneous list functions as a puzzle in a previous post. I’ll repeat them here for convenience.

map-pairs takes a list of items and maps a function over all pairs of items. For example:

(map-pairs #’list ’(1 2 3))

((1 2) (1 3) (1 4) (2 3) (2 4) (3 4))

revmap is like map, but it returns a list in reverse order.

revmap-cons, given a car and list of cdrs, returns a list of lists where each list has the car and one of the cdrs. The lists are returned in reverse order.

revmappend is like mappend, but it returns the list in reverse order.

remove-one-element returns a list of lists. Each sublist is the input list with one element removed.

Miscellaneous scanner

scan-suffixes takes a sequence and returns a series of the suffixes of the sequence. If include-empty? is true (the default), then the empty sequence is the last suffix. If proper? is true (default false), then the original full sequence is omitted from the series.

---

Armed with these miscellaneous functions, we can tackle the puzzles. I’ll write up some solutions in the next few posts.