Applied topology! Instead of using the standard even-odd raycasting trick for winding number (which I didn’t remember), I constructed an explicit inward-pointing normal at each edge of the large polygon. This way you can test directly whether edges that lie on the boundary of your candidate rectangle have the right orientation. The code isn’t pretty (edge-exterior-to-rect? is particularly awful), and I’m sure it could be made faster, but this worked almost the first time.

(ql:quickload :str)

(defun parse-line (line)
  (map 'vector #'parse-integer (str:split "," line)))

(defun read-inputs (filename)
  (let ((lines (uiop:read-file-lines filename)))
    (make-array (list (length lines) 2)
                :initial-contents (mapcar #'parse-line lines))))

(defun area (corners v w)
  "Yield the area of the rectangle between two diagonally opposite corners identified by index."
  (* (1+ (abs (- (aref corners v 0) (aref corners w 0))))
     (1+ (abs (- (aref corners v 1) (aref corners w 1))))))

(defun main-1 (filename)
  (let* ((red-tiles (read-inputs filename))
         (ntiles (car (array-dimensions red-tiles))))
    (loop for v from 0 to (1- ntiles)
          maximize (loop for w from 0 to (1- v)
                         maximize (area red-tiles v w)))))

;;; A rectangle is enclosed by the region if and only if both of the following are true:
;;; 1. No edge of the region passes through the interior of the rectangle;
;;; 2. When an edge of the region runs along an edge of the rectangle, the interior of
;;;    the region and the interior of the rectangle lie on the same side.
;;; So our first problem is to find the interior side of each edge of the region.

(defun edges-with-interior (corners)
  ;; Anchor: a vertical edge with minimum x coordinate has the interior on the +x side
  (let* ((n (car (array-dimensions corners)))
         (min-x (loop for i from 0 to (1- n) minimize (aref corners i 0)))
         (arg-min-x (loop for i from 0 to (1- n)
                          when (= (aref corners i 0) min-x)
                            return i))
         ;; Mapping from edge direction unit vector to inward-pointing normal to edge
         ;; Initial inward normal is known to be #(1 0); sense of the rotation from edge
         ;; direction depends on direction of initial edge
         (edge-interior-dir
           (if (> (aref corners (1+ arg-min-x) 1) (aref corners arg-min-x 1)) ; +y
               '((#(0 1) . #(1 0)) (#(1 0) . #(0 -1)) (#(0 -1) . #(-1 0)) (#(-1 0) . #(0 1)))
               '((#(0 -1) . #(1 0)) (#(1 0) . #(0 1)) (#(0 1) . #(-1 0)) (#(-1 0) . #(0 -1)))))
         (interior-labeled-edges
           (loop for i from arg-min-x to (+ arg-min-x n -1)
                 collect (let* ((j (mod i n))
                                (jj (mod (1+ i) n))
                                (unit-edge
                                  (vector (signum (- (aref corners jj 0) (aref corners j 0)))
                                          (signum (- (aref corners jj 1) (aref corners j 1)))))
                                (unit-interior-normal
                                  (cdr (assoc unit-edge edge-interior-dir :test #'equalp))))
                           (vector (aref corners j 0) (aref corners j 1)
                                   (aref corners jj 0) (aref corners jj 1)
                                   (aref unit-interior-normal 0) (aref unit-interior-normal 1))))))
    (make-array (list n 6) :initial-contents interior-labeled-edges)))

(defun edge-exterior-to-rect? (corners edges-with-interior i v w)
  (let ((rxmin (min (aref corners v 0) (aref corners w 0)))
        (rxmax (max (aref corners v 0) (aref corners w 0)))
        (rymin (min (aref corners v 1) (aref corners w 1)))
        (rymax (max (aref corners v 1) (aref corners w 1)))
        (exmin (min (aref edges-with-interior i 0) (aref edges-with-interior i 2)))
        (exmax (max (aref edges-with-interior i 0) (aref edges-with-interior i 2)))
        (eymin (min (aref edges-with-interior i 1) (aref edges-with-interior i 3)))
        (eymax (max (aref edges-with-interior i 1) (aref edges-with-interior i 3)))
        (ixdir (aref edges-with-interior i 4))
        (iydir (aref edges-with-interior i 5)))
    (or (and (< exmin rxmin) (<= exmax rxmin)) ; edge is left of rectangle
        (and (>= exmin rxmax) (> exmax rxmax)) ; edge is right of rectangle
        (and (< eymin rymin) (<= eymax rymin)) ; edge is above rectangle
        (and (>= eymin rymax) (> eymax rymax)) ; edge is below rectangle
        (and (= exmin exmax rxmin) (= ixdir 1) (= iydir 0)) ; edge lies on left side pointing in
        (and (= exmin exmax rxmax) (= ixdir -1) (= iydir 0)) ; edge lies on right side pointing in
        (and (= eymin eymax rymin) (= ixdir 0) (= iydir 1)) ; edge lies on top side pointing in
        (and (= eymin eymax rymax) (= ixdir 0) (= iydir -1))))) ; edge lies on bottom side pointing in

(defun enclosed? (corners edges-with-interior v w)
  (loop for i from 0 to (1- (car (array-dimensions edges-with-interior)))
        unless (edge-exterior-to-rect? corners edges-with-interior i v w)
          return nil
        finally (return t)))

(defun main-2 (filename)
  (let* ((red-tiles (read-inputs filename))
         (ntiles (car (array-dimensions red-tiles)))
         (edges-with-interior (edges-with-interior red-tiles)))
    (loop for v from 0 to (1- ntiles)
          maximize (loop for w from 0 to (1- v)
                         maximize (if (enclosed? red-tiles edges-with-interior v w)
                                      (area red-tiles v w)
                                      0)))))

Another factor of 10 in problem size would have required more efficient data structures and the “correct” algorithm. But as it is, we can get by with sets-as-lists and just updating a hash table, if we’re willing to wait a few seconds for the answer.

(ql:quickload :str)

(defun parse-line (line)
  (coerce (mapcar #'parse-integer (str:split "," line)) 'vector))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (make-array (list (length input-lines) 3)
                :initial-contents (mapcar #'parse-line input-lines))))

(defun distance (points p q)
  (flet ((square (x) (* x x)))
    (sqrt (+ (square (- (aref points p 0) (aref points q 0)))
             (square (- (aref points p 1) (aref points q 1)))
             (square (- (aref points p 2) (aref points q 2)))))))

(defun all-labeled-edges (points)
  (loop for j from 0 to (1- (car (array-dimensions points)))
        nconcing (loop for i from 0 to (1- j)
                       collect (list (distance points i j) i j))))

(defun short-labeled-edges (points nedges)
  (subseq (sort (all-labeled-edges points) #'< :key #'first) 0 nedges))

(defun adjacency-map (labeled-edges)
  (let ((result (make-hash-table)))
    (loop for (nil v w) in labeled-edges
          do (setf (gethash v result) (cons w (gethash v result)))
             (setf (gethash w result) (cons v (gethash w result))))
    result))

(defun components (n adjacency-map)
  (let ((remaining (loop for i from 0 to (1- n) collect i))
        (result nil))
    (loop for v = (car remaining)
          until (null v)
          do (let ((this-component nil)
                   (next-component (list v)))
               (loop until (subsetp next-component this-component)
                     do (progn
                          (setf this-component next-component)
                          (setf next-component
                                (reduce #'union
                                        (cons this-component
                                              (mapcar #'(lambda (w) (gethash w adjacency-map))
                                                      this-component))))))
               (setf result (cons this-component result))
               (loop for w in this-component
                     do (setf remaining (delete w remaining)))))
    result))

(defun main-1 (filename)
  (let* ((points (read-inputs filename))
         (adjacency (adjacency-map (short-labeled-edges points 1000)))
         (components (components (car (array-dimensions points)) adjacency))
         (lengths (sort (mapcar #'length components) #'>)))
    (* (car lengths) (cadr lengths) (caddr lengths))))

(defun fusing-edge (n labeled-edges)
  (let ((sorted-edges (sort labeled-edges #'< :key #'first))
        (components (make-hash-table)))
    (loop for i from 0 to (1- n)
          do (setf (gethash i components) (list i)))
    (loop for (nil v w) in sorted-edges
          do (let ((new-component (union (gethash v components) (gethash w components))))
               (cond ((= (length new-component) n)
                      (return (list v w)))
                     ((not (subsetp new-component (gethash v components)))
                      (loop for x in new-component
                            do (setf (gethash x components) new-component))))))))

(defun main-2 (filename)
  (let* ((points (read-inputs filename))
         (n (car (array-dimensions points))))
    (destructuring-bind (v w) (fusing-edge n (all-labeled-edges points))
      (* (aref points v 0) (aref points w 0)))))

My choice of representation for part 1 ended up being fortunate, as all I needed to change for part 2 was three setf in propagate that became incf. This was also another good use case for multiple return values, as it’s the beam vector you want to reduce on, but for part 1 the split count needs to come along for the ride.

(defun parse-line (line)
  (let ((result (make-array (length line) :initial-element 0)))
    (loop for i from 0 to (1- (length line))
          if (member (char line i) '(#\^ #\S))
            do (setf (aref result i) 1))
    result))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (mapcar #'parse-line input-lines)))

(defun propagate (in-beams splitters)
  (let ((out-beams (make-array (length in-beams) :initial-element 0))
        (splits 0))
    (loop for i from 0 to (1- (length in-beams))
          if (not (zerop (aref in-beams i)))
            do (if (not (zerop (aref splitters i)))
                   (progn (incf (aref out-beams (1- i)) (aref in-beams i))
                          (incf (aref out-beams (1+ i)) (aref in-beams i))
                          (incf splits))
                   (incf (aref out-beams i) (aref in-beams i))))
    (values out-beams splits)))

(defun propagate-all (initial-beam-vector splitter-map)
  (let* ((total-splits 0)
         (final-beam-vector
           (reduce #'(lambda (in-beams splitters)
                       (multiple-value-bind (out-beams this-splits)
                           (propagate in-beams splitters)
                         (incf total-splits this-splits)
                         out-beams))
                   splitter-map :initial-value initial-beam-vector)))
    (values final-beam-vector total-splits)))

(defun main-1 (filename)
  (let ((grid (read-inputs filename)))
    (multiple-value-bind (final-beam-vector total-splits)
        (propagate-all (car grid) (cdr grid))
      total-splits)))

(defun main-2 (filename)
  (let ((grid (read-inputs filename)))
    (multiple-value-bind (final-beam-vector total-splits)
        (propagate-all (car grid) (cdr grid))
      (reduce #'+ (coerce final-beam-vector 'list)))))

Ironically for Lisp, a good chunk of the work here is type conversion, because strings, vectors, multidimensional arrays, characters, and numbers don’t have implicit conversions between them; you have to specify what you want explicitly. I also found it easier to manually transpose the character array for part 2 rather than traverse in column-major order, because that makes the relationship between input and output data structure more transparent.

(ql:quickload :str)
(ql:quickload :array-operations)

(defun parse-line-1 (line)
  (let ((broken-line (str:split " " (str:collapse-whitespaces (str:trim line)))))
    (mapcar #'(lambda (s)
                (cond ((equal s "+") #'+)
                      ((equal s "*") #'*)
                      (t (parse-integer s))))
            broken-line)))

(defun read-inputs-1 (filename)
  (let* ((input-lines (uiop:read-file-lines filename)))
    (mapcar #'parse-line-1 input-lines)))

(defun main-1 (filename)
  (let* ((problems (read-inputs-1 filename))
         (arguments (apply #'mapcar #'list (butlast problems))))
    (reduce #'+ (mapcar #'apply (car (last problems)) arguments))))

(defun parse-operands-2 (lines)
  (let* ((initial-rows (length lines))
         (initial-cols (length (car lines)))
         (flat-chars (make-array (list (* initial-rows initial-cols))
                                 :initial-contents (apply #'concatenate 'string lines)))
         (box-chars (make-array (list initial-rows initial-cols) :displaced-to flat-chars))
         (transposed-chars (aops:each-index (i j) (aref box-chars j i))))
    (loop for cv across (aops:split transposed-chars 1)
          for s = (str:trim (coerce cv 'string))
          collect (if (zerop (length s)) nil (parse-integer s)))))

(defun list-split (xs sep &optional (predicate #'equal))
  (let ((current nil)
        (result nil))
    (loop for x in xs
          do (if (funcall predicate x sep)
                 (progn
                   (setf result (cons (reverse current) result))
                   (setf current nil))
                 (setf current (cons x current)))
          finally (setf result (cons (reverse current) result)))
    (reverse result)))

(defun main-2 (filename)
  (let* ((lines (uiop:read-file-lines filename))
         (operators (parse-line-1 (car (last lines))))
         (operands (parse-operands-2 (butlast lines))))
    (loop for rator in operators
          for rands in (list-split operands nil)
          sum (apply rator rands))))

Nothing interesting here. I was tripped up momentarily by the fact that Common Lisp sort, while it’s a destructive operation, does not leave its input argument equal to its result! Typically you see either “nondestructive, returns a value” (Python sorted()) or “destructive, leaves the object in the final state” (Python list.sort()). Old school Lisp sort returns the sorted list and the input structure is not guaranteed to be meaningful afterward. Hope you weren’t using that pair for anything; it now points to hell.

(ql:quickload :str)

(defun read-inputs (filename)
  (let* ((input-lines (uiop:read-file-lines filename))
         (range-lines (remove-if-not #'(lambda (s) (find #\- s)) input-lines))
         (id-lines (remove-if #'(lambda (s) (or (zerop (length s)) (find #\- s))) input-lines)))
    (flet ((parse-range (line) (mapcar #'parse-integer (str:split "-" line))))
      (cons (mapcar #'parse-range range-lines)
            (mapcar #'parse-integer id-lines)))))

(defun fresh? (fresh-ranges id)
  "Return the first fresh range containing id, or nil if there is no such range.
  Assumes the fresh ranges are sorted to enable early exit."
  (loop for fresh-range in fresh-ranges
        when (<= (car fresh-range) id (cadr fresh-range))
          return fresh-range
        when (> (car fresh-range) id)
          return nil
        finally (return nil)))

(defun range< (range1 range2)
  (destructuring-bind (a1 b1) range1
    (destructuring-bind (a2 b2) range2
      (or (< a1 a2)
          (and (= a1 a2) (< b1 b2))))))

(defun main-1 (filename)
  (destructuring-bind (fresh-ranges . ids) (read-inputs filename)
    (let ((sorted-fresh-ranges (sort fresh-ranges #'range<)))
      (loop for id in ids
            sum (if (fresh? sorted-fresh-ranges id) 1 0)))))

(defun consolidate (fresh-ranges)
  "Remove redundancy in a sorted list of fresh ranges: emit non-overlapping ranges."
  (let ((result nil)
        (current-range (car fresh-ranges)))
    (loop for fresh-range in (cdr fresh-ranges)
          do (if (<= (car fresh-range) (cadr current-range))
                 (setf current-range (list (car current-range)
                                           (max (cadr current-range) (cadr fresh-range))))
                 (progn
                   (setf result (cons current-range result))
                   (setf current-range fresh-range)))
          finally (setf result (cons current-range result)))
    result))

(defun main-2 (filename)
  (destructuring-bind (fresh-ranges . ids) (read-inputs filename)
    (let ((sorted-fresh-ranges (sort fresh-ranges #'range<)))
      (reduce #'+
              (mapcar #'(lambda (range) (1+ (- (cadr range) (car range))))
                      (consolidate sorted-fresh-ranges))))))

This is the first day I’ve wished I were working in J, like last year, instead of Lisp. Common Lisp arrays show the age of the language design. They’re basically C arrays with less convenient syntax; if you want higher-order array iteration you have to write it yourself or use a package that provides it. This solution is also less efficient than it could be for part 2, because I recompute the full neighbors array on each iteration rather than updating it incrementally.

(defun read-inputs (filename)
  (let* ((input-lines (uiop:read-file-lines filename))
         (rows (length input-lines))
         (cols (length (car input-lines)))
         (result (make-array (list rows cols) :initial-element 0)))
    (loop for line in input-lines
          for y from 0 to (1- rows)
          do (loop for x from 0 to (1- cols)
                   if (eql (char line x) #\@)
                     do (setf (aref result y x) 1)))
    result))

(defun neighbors (grid)
  (let* ((dimensions (array-dimensions grid))
         (rows (car dimensions))
         (cols (cadr dimensions))
         (result (make-array dimensions :initial-element 0)))
    (flet ((neighbors-at (y x)
             (loop for dy from -1 to 1
                   sum (loop for dx from -1 to 1
                             sum (let ((yy (+ y dy))
                                       (xx (+ x dx)))
                                   (if (and (>= yy 0)
                                            (< yy rows)
                                            (>= xx 0)
                                            (< xx cols)
                                            (not (and (= dx 0) (= dy 0)))
                                            (> (aref grid yy xx) 0))
                                       1
                                       0))))))
      (loop for y from 0 to (1- rows)
            do (loop for x from 0 to (1- cols)
                     do (setf (aref result y x) (neighbors-at y x))))
      result)))

(defun main-1 (filename)
  (let* ((grid (read-inputs filename))
         (dimensions (array-dimensions grid))
         (neighbors-grid (neighbors grid)))
    (loop for y from 0 to (1- (car dimensions))
          sum (loop for x from 0 to (1- (cadr dimensions))
                    sum (if (and (> (aref grid y x) 0)
                                 (< (aref neighbors-grid y x) 4))
                            1
                            0)))))

(defun remove-accessible (grid)
  (let* ((dimensions (array-dimensions grid))
         (neighbors-grid (neighbors grid))
         (removed 0))
    (loop for y from 0 to (1- (car dimensions))
          do (loop for x from 0 to (1- (cadr dimensions))
                   do (if (and (> (aref grid y x) 0)
                               (< (aref neighbors-grid y x) 4))
                          (progn
                            (setf (aref grid y x) 0)
                            (incf removed)))))
    removed))

(defun main-2 (filename)
  (let ((grid (read-inputs filename))
        (removed 0))
    (loop for this-removed = (remove-accessible grid)
          until (zerop this-removed)
          do (incf removed this-removed))
    removed))

This problem was quite straightforward; I think it probably could have been day 1. The only interesting thing here is the use of values and multiple-value-bind, which are the standard way in Common Lisp to give a function a primary return value but also one or more advisory return values. This lets you return a rich data structure for consumers who want it, but consumers who don’t want it don’t need to parse that entire data structure to get the primary return value.

(defun parse-line (line)
  (let ((digits (loop for i from 0 to (1- (length line))
                      collect (parse-integer line :start i :end (1+ i)))))
    (make-array (list (length digits)) :initial-contents digits)))

(defun read-inputs (filename)
  (let* ((input-lines (uiop:read-file-lines filename)))
    (mapcar #'parse-line input-lines)))

(defun arg-max (v &key start end)
  "Yield the index and the greatest element of vector v, between indices start (inclusive) and
  end (exclusive) if they are supplied. Returns the earliest instance of the maximum."
  (let* ((start (max 0 (or start 0)))
         (end (min (length v) (or end (length v))))
         (arg-max start)
         (val-max (aref v start)))
    (loop for i from start to (1- end)
          if (> (aref v i) val-max)
            do (progn (setf arg-max i)
                      (setf val-max (aref v i)))
          finally (return (values arg-max val-max)))))

(defun bank-max-joltage (digits bank)
  (let ((search-start 0)
        (result 0))
    (loop for d from 0 to (1- digits)
          do (multiple-value-bind (digit-pos digit)
                 (arg-max bank :start search-start :end (+ (length bank) (- digits) (1+ d)))
               (setf search-start (1+ digit-pos))
               (setf result (+ (* 10 result) digit))))
    result))

(defun main-1 (filename)
  (reduce #'+ (mapcar #'(lambda (bank) (bank-max-joltage 2 bank))
                      (read-inputs filename))))

(defun main-2 (filename)
  (reduce #'+ (mapcar #'(lambda (bank) (bank-max-joltage 12 bank))
                      (read-inputs filename))))

An ID is invalid if and only if it is divisible by a number of the form 1001001001, where the 1’s are separated by the same number of 0’s and the block length times the number of blocks equals the digit length of the ID. Given that, the problem reduces to summing the members of some arithmetic progressions; we never have to iterate over the members of a range at all.

(ql:quickload :str)

(defun parse-range (range)
  (mapcar #'parse-integer (str:split "-" range)))

(defun parse-line (line)
  (mapcar #'parse-range (str:split "," line)))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (parse-line (car input-lines))))

(defun split-range (start end)
  "Split the range (start end) into a list of ranges whose bounds have same number of digits."
  (let ((start-digits (1+ (floor (log start 10))))
        (end-digits (1+ (floor (log end 10)))))
    (if (< start-digits end-digits)
        (cons (list start (1- (expt 10 start-digits)))
              (split-range (expt 10 start-digits) end))
        (list (list start end)))))

(defun sum-multiples-in-range (d start end)
  "Add up the sum of all multiples n of d satisfying start <= n <= end."
  (multiple-value-bind (q0 r0) (floor start d)
    ;; q1, q2 are coefficients of the least and greatest multiple of d potentially in range
    (let ((q1 (if (zerop r0) q0 (1+ q0)))
          (q2 (floor end d)))
      (if (> q1 q2)
          0
          (flet ((arith-up-to (n) (floor (* n (1+ n)) 2)))
            (* d (- (arith-up-to q2) (arith-up-to (1- q1)))))))))

(defun sum-invalid-in-range (range repeat-count)
  "Add up the sum of all IDs in range start <= n <= end which are invalid due to having
  exactly repeat-count repeats."
  (loop for homogeneous-range in (apply #'split-range range)
        sum (destructuring-bind (hstart hend) homogeneous-range
              (let ((digits (1+ (floor (log hstart 10)))))
                (if (not (zerop (mod digits repeat-count)))
                    0
                    (let ((divisor
                            (loop for k from 0 to (1- digits) by (floor digits repeat-count)
                                  sum (expt 10 k))))
                      (sum-multiples-in-range divisor hstart hend)))))))

(defun main-1 (filename)
  (reduce #'+ (mapcar #'(lambda (range) (sum-invalid-in-range range 2))
                      (read-inputs filename))))

(defun sum-all-invalids-in-range (range)
  "Add up the sum of _all_ invalid IDs (with any available repeat count) in range."
  ;; Composite repeat counts will be overcounted. Because the maximum digit length of
  ;; inputs is limited, we can cheat and just use an explicit constant for weights.
  (let ((repeat-weights '((2 1) (3 1) (5 1) (6 -1) (7 1) (10 -1))))
    (loop for repeat-weight in repeat-weights
          sum (destructuring-bind (repeat-count weight) repeat-weight
                (* weight (sum-invalid-in-range range repeat-count))))))

(defun main-2 (filename)
  (reduce #'+ (mapcar #'sum-all-invalids-in-range (read-inputs filename))))

I agree with strlcpy – computing was better in the 1980s. Let’s try the version of the 1980s where Lisp Machines were going to power the AI future. It can’t be any worse than the AI future we’ve got right now.

(This is SBCL, not a Lisp Machine emulator, because I’m not that hardcore.)

(defun parse-line (line)
  (let ((sign (if (eql (char line 0) #\R) 1 -1))
        (number (parse-integer (subseq line 1))))
    (* sign number)))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (mapcar #'parse-line input-lines)))

(defun rotate (pos rotation)
  (mod (+ pos rotation) 100))

(defun main-1 (filename)
  (let ((rotations (read-inputs filename))
        (pos 50))
    (loop for rotation in rotations
          do (setf pos (rotate pos rotation))
          sum (if (= pos 0) 1 0))))

(defun zero-crossings (pos rotation)
  (if (> rotation 0)
      (floor (+ rotation pos) 100)
      (let ((neg-pos (if (zerop pos) pos (- pos 100))))
        (- (ceiling (+ rotation neg-pos) 100)))))

(defun main-2 (filename)
  (let ((rotations (read-inputs filename))
        (pos 50))
    (loop for rotation in rotations
          sum (zero-crossings pos rotation) into crossings
          do (setf pos (rotate pos rotation))
          finally (return crossings))))

I’m sure there are 17 different graph libraries I could have used for the graph representation and connected components, but it seemed to be in the spirit of the question to write it myself. Nothing interesting about the parent search though – it’s just brute-force comparison.

(ql:quickload :str)

(defun parse-line (line)
  (let ((index-and-codes (str:split ":" line)))
    (cons (parse-integer (car index-and-codes)) (cadr index-and-codes))))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (mapcar #'parse-line input-lines)))

(defun can-be-child-of? (parent1 parent2 child)
  (loop for i from 0 to (1- (length child))
        unless (or (eql (char child i) (char parent1 i))
                   (eql (char child i) (char parent2 i)))
          return nil
        finally (return t)))

(defun similarity (genome1 genome2)
  (loop for i from 0 to (1- (length genome1))
        sum (if (eql (char genome1 i) (char genome2 i)) 1 0)))

(defun main-1 (filename)
  (let ((genomes (read-inputs filename)))
    (loop for arrangement in '((1 2 3) (2 3 1) (3 1 2))
          maximize
          (destructuring-bind (parent1-index parent2-index child-index) arrangement
            (let ((parent1 (cdr (assoc parent1-index genomes)))
                  (parent2 (cdr (assoc parent2-index genomes)))
                  (child (cdr (assoc child-index genomes))))
              (if (can-be-child-of? parent1 parent2 child)
                  (* (similarity parent1 child) (similarity parent2 child))
                  0))))))

(defun find-parents (genomes child-pair)
  (loop named loop1
        for tail1 on genomes
        for parent1-pair = (car tail1)
        do (loop for parent2-pair in (cdr tail1)
                 when (and
                       (/= (car parent1-pair) (car child-pair))
                       (/= (car parent2-pair) (car child-pair))
                       (can-be-child-of? (cdr parent1-pair) (cdr parent2-pair) (cdr child-pair)))
                   do (return-from loop1 (cons (car parent1-pair) (car parent2-pair))))
        finally (return-from loop1 nil)))

(defun child-relationships (genomes)
  (mapcar #'(lambda (child-pair)
              (cons (car child-pair) (find-parents genomes child-pair)))
          genomes))

(defun main-2 (filename)
  (let* ((genomes (read-inputs filename))
         (child-relationships (child-relationships genomes)))
    (loop for child-rel in child-relationships
          sum (destructuring-bind (child-idx . parent-idxs) child-rel
                (if (null parent-idxs)
                    0
                    (let ((parent1 (cdr (assoc (car parent-idxs) genomes)))
                          (parent2 (cdr (assoc (cdr parent-idxs) genomes)))
                          (child (cdr (assoc child-idx genomes))))
                      (* (similarity parent1 child) (similarity parent2 child))))))))

(defun relationship-graph (child-relationships)
  (let ((edges (mapcan #'(lambda (child-rel)
                           (destructuring-bind (child-idx . parent-idxs) child-rel
                             (if (null parent-idxs)
                                 nil
                                 (list (cons child-idx (car parent-idxs))
                                       (cons child-idx (cdr parent-idxs))))))
                       child-relationships))
        (graph (make-hash-table)))
    (loop for edge in edges
          do (destructuring-bind (x . y) edge
               (setf (gethash x graph) (cons y (gethash x graph)))
               (setf (gethash y graph) (cons x (gethash y graph)))))
    graph))

(defun component-of (graph vertex)
  (labels ((iter (so-far)
             (let ((next (reduce #'union
                                 (mapcar #'(lambda (v) (gethash v graph)) so-far)
                                 :initial-value so-far)))
               (if (subsetp next so-far)
                   next
                   (iter next)))))
    (iter (list vertex))))

(defun all-components (graph vertices)
  (labels ((iter (so-far vertices-left)
             (if (null vertices-left)
                 so-far
                 (let ((comp (component-of graph (car vertices-left))))
                   (iter (cons comp so-far)
                         (set-difference vertices-left comp))))))
    (iter nil vertices)))

(defun main-3 (filename)
  (let* ((genomes (read-inputs filename))
         (child-relationships (child-relationships genomes))
         (relationship-graph (relationship-graph child-relationships))
         (keys (mapcar #'car child-relationships))
         (components (all-components relationship-graph keys)))
    (reduce #'+
            (car (sort components #'(lambda (c1 c2) (> (length c1) (length c2))))))))

Common Lisp’s loop macro has a pretty crazy list of features. New ones in this solution are for x on xs, which binds the iteration variable x to successive tails (instead of elements) of xs, and maximize, which is an alternative accumulator to sum. There’s nothing interesting about the solution itself though – simple brute-force enumeration.

(ql:quickload :str)

(defun parse-line (line)
  (mapcar #'parse-integer (str:split "," line)))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (parse-line (car input-lines))))

(defun pairs (ns)
  (loop for tail on ns
        if (not (null (cdr tail)))
          collect (cons (car tail) (cadr tail))))

(defun through-center? (nails segment)
  (destructuring-bind (x . y) segment
    (= (mod (- x y) nails) (/ nails 2))))

(defun main-1 (filename)
  (let ((positions (read-inputs filename)))
    (loop for segment in (pairs positions)
          sum (if (through-center? 32 segment) 1 0))))

(defun crosses? (seg1 seg2)
  "When everything is normalized to 1..nails indices, seg1 crosses seg2 iff one of seg2's
  endpoints lies strictly between the endpoints of seg1, and the other one of seg2's endpoints
  lies strictly below or above the endpoints of seg1."
  (destructuring-bind (x1 . y1) seg1
    (destructuring-bind (x2 . y2) seg2
      (let ((big1 (max x1 y1))
            (small1 (min x1 y1)))
        (or (and (< small1 x2 big1)
                 (or (< y2 small1) (> y2 big1)))
            (and (or (< x2 small1) (> x2 big1))
                 (< small1 y2 big1)))))))

(defun main-2 (filename)
  (let ((positions (read-inputs filename)))
    (loop for seg-list on (pairs positions)
          sum (loop for seg2 in (cdr seg-list)
                    sum (if (crosses? (car seg-list) seg2) 1 0)))))

(defun score (threads seg)
  (loop for thread in threads
        sum (if (crosses? thread seg) 1 0)))

(defun main-3 (filename)
  (let* ((positions (read-inputs filename))
         (threads (pairs positions))
         (nails 256))
    (loop for x1 from 1 to nails
          maximize (loop for y1 from (1+ x1) to nails
                         maximize (score threads (cons x1 y1))))))

Even after 20 years in “nicer”, “safer”, “more modern” languages … I still miss Lisp. It’s the only language that makes me feel like I’m sculpting in clay, instead of carving stone (Haskell) or laying bricks (Java) or building with Lego (Python). Sure, sometimes the clay comes out kind of lumpy, but that’s part of the experience.

(ql:quickload :str)
(ql:quickload :cl-ppcre)

(defun parse-names-line (line)
  (str:split "," line))

(defun parse-rule-line (line)
  (ppcre:register-groups-bind
      (initial finals)
      ("^([A-Za-z]) > ([A-Za-z,]+)$" line)
    (cons (char initial 0)
          (mapcar #'(lambda (s) (char s 0)) (str:split "," finals)))))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (list (cons :names (parse-names-line (car input-lines)))
          (cons :rules (mapcar #'parse-rule-line (cddr input-lines))))))

(defun valid? (rules name)
  (flet ((valid-pair? (x y)
           (member y (cdr (assoc x rules)))))
    (loop for i from 0 to (- (length name) 2)
          when (not (valid-pair? (char name i) (char name (1+ i))))
            return nil
          finally (return t))))

(defun main-1 (filename)
  (let* ((names-and-rules (read-inputs filename))
         (names (cdr (assoc :names names-and-rules)))
         (rules (cdr (assoc :rules names-and-rules))))
    (loop for name in names
          when (valid? rules name)
            return name)))

(defun main-2 (filename)
  (let* ((names-and-rules (read-inputs filename))
         (names (cdr (assoc :names names-and-rules)))
         (rules (cdr (assoc :rules names-and-rules))))
    (loop for i from 0 to (1- (length names))
          sum (if (valid? rules (nth i names)) (1+ i) 0))))

(defun augment (rules prefixes)
  (flet ((augment-one (prefix)
           (mapcar #'(lambda (c) (str:concat prefix (string c)))
                   (cdr (assoc (uiop:last-char prefix) rules)))))
    (mapcan #'augment-one prefixes)))

(defun main-3 (filename)
  (let* ((min-length 7)
         (max-length 11)
         (names-and-rules (read-inputs filename))
         (rules (cdr (assoc :rules names-and-rules)))
         (prefixes (remove-if-not #'(lambda (prefix) (valid? rules prefix))
                                  (cdr (assoc :names names-and-rules))))
         (names-by-length (make-hash-table)))
    (loop for l from (apply #'min (mapcar #'length prefixes)) to max-length
          do (setf (gethash l names-by-length)
                   (remove-duplicates
                    (append (remove-if-not #'(lambda (prefix) (= l (length prefix))) prefixes)
                            (augment rules (gethash (1- l) names-by-length)))
                    :test #'equal)))
    (loop for l from min-length to max-length
          sum (length (gethash l names-by-length)))))

In part 3 we can avoid thinking about the structure of the input string (left vs center vs right portions) and get the efficiency back by building up the counts of available mentors in each window position incrementally. The result is more code and takes a lot of space, but minimizes the number of irregular boundary cases.

(ql:quickload :str)

(defun parse-line (line)
  (let ((result (make-hash-table :test #'equal)))
    (loop for n from 0 to (1- (length line))
          for c = (char line n)
          for old = (gethash c result)
          do (setf (gethash c result) (cons n old)))
    result))

(defun read-inputs (filename)
  (parse-line (car (uiop:read-file-lines filename))))

(defun pairs (pos-hash early-type late-type)
  (loop for early-index in (gethash early-type pos-hash)
        sum (length (remove-if #'(lambda (late-index) (< late-index early-index))
                               (gethash late-type pos-hash)))))

(defun main-1 (filename)
  (pairs (read-inputs filename) #\A #\a))

(defun main-2 (filename)
  (let ((pos-hash (read-inputs filename)))
    (reduce #'+
            (mapcar #'(lambda (type-pair) (apply #'pairs (cons pos-hash type-pair)))
                    '((#\A #\a) (#\B #\b) (#\C #\c))))))

(defun char-at (base-string pos)
  (char base-string (mod pos (length base-string))))

(defun type-window-counts (base-string copies radius type)
  (let* ((max-pos (* copies (length base-string)))
         (counts (make-array max-pos)))
    (setf (aref counts 0)
          (loop for i from 0 to radius
                sum (if (eql type (char-at base-string i)) 1 0)))
    (loop for i from 1 to (1- max-pos)
          do (let ((new-count
                     (+ (aref counts (1- i))
                        (if (and (< (+ i radius) max-pos)
                                 (eql type (char-at base-string (+ i radius))))
                            1 0)
                        (if (and (>= (- i (1+ radius)) 0)
                                 (eql type (char-at base-string (- i (1+ radius)))))
                            -1 0))))
               (setf (aref counts i) new-count)))
    counts))

(defun window-counts (base-string copies radius types)
  (mapcar #'(lambda (type)
              (cons type (type-window-counts base-string copies radius type)))
          types))

(defun count-pairs (base-string copies source-type target-type-window-counts)
  (let ((max-pos (* copies (length base-string))))
    (loop for i from 0 to (1- max-pos)
          sum (if (eql source-type (char-at base-string i))
                  (aref target-type-window-counts i) 0))))

(defun main-3 (filename)
  (let* ((base-string (car (uiop:read-file-lines filename)))
         (copies 1000)
         (radius 1000)
         (type-pairs '((#\a #\A) (#\b #\B) (#\c #\C)))
         (window-counts (window-counts base-string copies radius (mapcar #'cadr type-pairs))))
    (reduce #'+
            (mapcar #'(lambda (type-pair)
                        (count-pairs base-string copies (car type-pair)
                                     (cdr (assoc (cadr type-pair) window-counts))))
                    type-pairs))))

Does anybody miss old-school Lisp mutable data structures where you’re kinda a functional language but you still have to worry about the difference between values and object identity? I’m not sure anybody does, but this is a retrocomputing house.

(ql:quickload :str)

(defun parse-line (line)
  (let* ((id-and-nums (str:split ":" line))
         (id (parse-integer (car id-and-nums)))
         (nums (mapcar #'parse-integer (str:split "," (cadr id-and-nums)))))
    (cons id nums)))

(defun read-inputs (filename)
  (mapcar #'parse-line (uiop:read-file-lines filename)))

(defun fishbone-push (fb n)
  (if (null fb)
      (list (vector nil n nil))
      (let ((rib (car fb)))
        (cond ((and (null (aref rib 0))
                    (< n (aref rib 1)))
               (setf (aref rib 0) n)
               fb)
              ((and (null (aref rib 2))
                    (> n (aref rib 1)))
               (setf (aref rib 2) n)
               fb)
              ((null (cdr fb))
               (nconc fb (fishbone-push (cdr fb) n)))
              (t
               (fishbone-push (cdr fb) n)
               fb)))))

(defun make-fishbone (ns)
  (reduce #'fishbone-push ns :initial-value nil))

(defun quality (ns)
  (let ((fb (make-fishbone ns)))
    (parse-integer (apply #'str:concat
                          (mapcar #'(lambda (rib) (write-to-string (aref rib 1)))
                                  fb)))))

(defun main-1 (filename)
  (quality (cdar (read-inputs filename))))

(defun main-2 (filename)
  (let ((qualities (mapcar #'quality (mapcar #'cdr (read-inputs filename)))))
    (- (apply #'max qualities) (apply #'min qualities))))

(defun complex-quality (idx ns)
  (let* ((fb (make-fishbone ns))
         (quality
           (parse-integer (apply #'str:concat
                                 (mapcar #'(lambda (rib) (write-to-string (aref rib 1)))
                                         fb))))
         (rib-qualities
           (mapcar #'(lambda (rib)
                       (parse-integer
                        (apply #'str:concat
                               (mapcar #'write-to-string
                                       (remove-if #'null (coerce rib 'list))))))
                   fb)))
    (list (cons :quality quality)
          (cons :rib-qualities rib-qualities)
          (cons :index idx))))

(defun list> (ns1 ns2)
  (cond ((null ns1) nil)
        ((null ns2) t)
        ((> (car ns1) (car ns2)) t)
        ((< (car ns1) (car ns2)) nil)
        (t (list> (cdr ns1) (cdr ns2)))))

(defun cq> (cq1 cq2)
  (let ((q1 (cdr (assoc :quality cq1)))
        (q2 (cdr (assoc :quality cq2))))
    (cond ((> q1 q2) t)
          ((< q1 q2) nil)
          (t
           (let ((rq1 (cdr (assoc :rib-qualities cq1)))
                 (rq2 (cdr (assoc :rib-qualities cq2))))
             (cond ((list> rq1 rq2) t)
                   ((list> rq2 rq1) nil)
                   (t
                    (> (cdr (assoc :index cq1))
                       (cdr (assoc :index cq2))))))))))

(defun checksum (idxs)
  (loop for idx in idxs
        for n from 1 to (length idxs)
        sum (* idx n)))

(defun main-3 (filename)
  (let ((inputs (read-inputs filename))
        (sword-qualities (make-hash-table)))
    (loop for idx-ns in inputs
          do (setf (gethash (car idx-ns) sword-qualities)
                   (complex-quality (car idx-ns) (cdr idx-ns))))
    (let ((sorted-idxs
            (sort (mapcar #'car inputs)
                  #'(lambda (idx1 idx2)
                      (cq> (gethash idx1 sword-qualities)
                           (gethash idx2 sword-qualities))))))
      (checksum sorted-idxs))))

In 1980 we didn’t have tuple or set or vector types. We addressed elements of our cons-based data structures with nonsense incantations like caddar and we liked it that way.

(ql:quickload :cl-ppcre)

(defun read-inputs (filename)
  (mapcar #'parse-integer (uiop:read-file-lines filename)))

(defun main-1 (filename)
  (let ((gears (read-inputs filename)))
    (truncate (* 2025 (/ (first gears) (car (last gears)))))))

(defun main-2 (filename)
  (let ((gears (read-inputs filename)))
    (ceiling (* 10000000000000 (/ (car (last gears)) (first gears))))))

(defun read-inputs-3 (filename)
  (flet ((parse-line (line)
           (or (ppcre:register-groups-bind
                   (a b)
                   ("^([0-9]+)[|]([0-9]+)$" line)
                 (cons (parse-integer a) (parse-integer b)))
               (let ((a (parse-integer line)))
                 (cons a a)))))
    (mapcar #'parse-line (uiop:read-file-lines filename))))

(defun gear-ratio-3 (gears)
  (labels ((iter (gears ratio)
             (if (< (length gears) 2)
                 ratio
                 (let ((out-gear (cdar gears))
                       (in-gear (caadr gears)))
                   (iter (cdr gears) (* ratio (/ out-gear in-gear)))))))
    (iter gears 1)))

(defun main-3 (filename)
  (let ((gears (read-inputs-3 filename)))
    (truncate (* 100 (gear-ratio-3 gears)))))

Common Lisp doesn’t have a built in set datatype, so you have to do uniqueness checking sort of by hand unless you want to pull in an external package.

(ql:quickload :str)

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (mapcar #'parse-integer (str:split "," (car input-lines)))))

(defun add-distinct (xs)
  (loop for x in (remove-duplicates (sort (copy-seq xs) #'>))
        sum x))

(defun main-1 (filename)
  (add-distinct (read-inputs filename)))

(defun main-2 (filename)
  (let* ((sizes (read-inputs filename))
         (first-20 (subseq (remove-duplicates (sort (copy-seq sizes) #'<)) 0 20)))
    (loop for x in first-20
          sum x)))

(defun count-max-copies (xs)
  (labels ((iter (xs cur-x cur-count max-count)
             (cond ((null xs)
                    max-count)
                   ((equal (car xs) cur-x)
                    (iter (cdr xs) cur-x (1+ cur-count) (max max-count (1+ cur-count))))
                   (t
                    (iter (cdr xs) (car xs) 1 max-count)))))
    (iter (cdr xs) (car xs) 1 1)))

(defun main-3 (filename)
  (count-max-copies (sort (read-inputs filename) #'<)))

I was sad to discover that division wasn’t actual complex division. As in some other languages, one has to implement this “division” by hand because the library designers assume that you never want truncating integer division together with complex numbers. Which is reasonable, I guess.

(ql:quickload :cl-ppcre)
(ql:quickload :str)

(defun parse-line (line)
  (ppcre:register-groups-bind
      (name x y)
      ("^([A-Za-z]+)=[[]([\-0-9.]+),([\-0-9.]+)[]]$" line)
    (cons name (complex (parse-integer x) (parse-integer y)))))

(defun read-inputs (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (parse-line (car input-lines))))

(defun fake-complex-division (y d)
  (complex (truncate (realpart y) (realpart d))
           (truncate (imagpart y) (imagpart d))))

(defun f (x a)
  (+ a (fake-complex-division (* x x) #C(10 10))))

(defun main-1 (filename)
  (let* ((a (cdr (read-inputs filename)))
         (result (f (f (f #C(0 0) a) a) a)))
    (str:concat "["
                (write-to-string (realpart result))
                ","
                (write-to-string (imagpart result))
                "]")))

(defun engrave? (p)
  (labels ((iter (x n)
             (if (zerop n)
                 t
                 (let ((next-x (+ p (fake-complex-division (* x x) #C(100000 100000)))))
                   (if (or (> (abs (realpart next-x)) 1000000)
                           (> (abs (imagpart next-x)) 1000000))
                       nil
                       (iter next-x (- n 1)))))))
    (iter 0 100)))

(defun count-engraves (a spacing)
  (let ((steps (/ 1000 spacing)))
    (loop for x from 0 to steps
          sum (loop for y from 0 to steps
                    for p = (+ a (complex (* spacing x) (* spacing y)))
                    sum (if (engrave? p) 1 0)))))

(defun main-2 (filename)
  (count-engraves (cdr (read-inputs filename)) 10))

(defun main-3 (filename)
  (count-engraves (cdr (read-inputs filename)) 1))

It’s been too long since I wrote any Lisp, so obviously I should use the one hallowed by decades of tradition, not any of the fancy new ones with sane naming conventions and unified library systems. :D

(ql:quickload :str)

(defun parse-insn (insn)
  (let ((direction (str:s-first insn))
        (magnitude (parse-integer (str:s-rest insn))))
    (* magnitude (cond ((equal direction "L") -1)
                       ((equal direction "R") 1)
                       (t 0)))))

(defun read-inputs-1 (filename)
  (let ((input-lines (uiop:read-file-lines filename)))
    (destructuring-bind (names _ instructions) input-lines
      (list (str:split "," names)
            (mapcar #'parse-insn (str:split "," instructions))))))

(defun apply-insns-1 (names insns)
  (let ((max-pos (- (length names) 1)))
    (labels ((apply-from (insns pos)
               (if (null insns)
                   (nth pos names)
                   (let* ((maybe-next-pos (+ pos (car insns)))
                          (next-pos (max 0 (min max-pos maybe-next-pos))))
                     (apply-from (cdr insns) next-pos)))))
      (apply-from insns 0))))

(defun main-1 (filename)
  (apply #'apply-insns-1 (read-inputs-1 filename)))

(defun apply-insns-2 (names insns)
  (labels ((apply-from (insns pos)
             (if (null insns)
                 (nth pos names)
                 (let ((next-pos (mod (+ pos (car insns)) (length names))))
                   (apply-from (cdr insns) next-pos)))))
    (apply-from insns 0)))

(defun main-2 (filename)
  (apply #'apply-insns-2 (read-inputs-1 filename)))

(defun apply-insns-3 (names insns)
  (let* ((vnames (coerce names 'vector))
         (n (length vnames)))
    (labels ((apply-from (insns)
               (if (null insns)
                   (aref vnames 0)
                   (let* ((tgt (mod (car insns) n))
                          (src-name (aref vnames 0))
                          (tgt-name (aref vnames tgt)))
                     (setf (aref vnames 0) tgt-name)
                     (setf (aref vnames tgt) src-name)
                     (apply-from (cdr insns))))))
      (apply-from insns))))

(defun main-3 (filename)
  (apply #'apply-insns-3 (read-inputs-1 filename)))