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