aoc2021 day19

aoc2021-day19.lisp

;;;; +----------------------------------------------------------------+
;;;; | Advent of Code 2021                                            |
;;;; +----------------------------------------------------------------+

(defpackage #:snippets/aoc2021/day19
  (:use #:cl)
  (:export
   #:day19))

(in-package #:snippets/aoc2021/day19)

(defstruct scanner
  number
  beacons)

(defun beacon- (beacon1 beacon2)
  (mapcar #'- beacon1 beacon2))

(defun beacon+ (beacon1 beacon2)
  (mapcar #'+ beacon1 beacon2))

(defun parse (input)
  (let ((scanner (make-scanner))
        (scanners '()))
    (labels ((finish-scanner ()
               (when (scanner-number scanner)
                 (setf (scanner-beacons scanner)
                       (nreverse (scanner-beacons scanner)))
                 (push scanner scanners)
                 (setf scanner (make-scanner)))))
      (dolist (numbers input)
        (ecase (length numbers)
          (0)
          (1
           (finish-scanner)
           (setf (scanner-number scanner) (first numbers)))
          (3
           (push numbers (scanner-beacons scanner)))))
      (finish-scanner)
      (nreverse scanners))))

(defun beacon-norm (beacon)
  (reduce #'+ beacon :key #'abs))

(defun beacon-norms (scanner reference)
  (mapcar (lambda (beacon)
            (beacon-norm (beacon- beacon reference)))
          (scanner-beacons scanner)))

(defun find-candidates (scanners)
  (let ((candidates '()))
    (loop for (s1 . s1-rest) on scanners
          do (dolist (s2 s1-rest)
               (block found-consistent
                 (dolist (b1 (scanner-beacons s1))
                   (let ((n1 (beacon-norms s1 b1)))
                     (dolist (b2 (scanner-beacons s2))
                       (let ((n2 (beacon-norms s2 b2)))
                         (let ((m (length (intersection n1 n2))))
                           (when (>= m 12)
                             (push (list s1 b1 s2 b2) candidates)
                             (return-from found-consistent))))))))))
    (nreverse candidates)))

(defun make-configuration (m o)
  (lambda (beacon)
    (let ((b1 (mapcar #'* beacon m)))
      (mapcar (lambda (i) (nth i b1)) o))))

(defun make-configurations ()
  (let ((configurations '()))
    (dolist (sx '(-1 +1))
      (dolist (sy '(-1 +1))
        (dolist (sz '(-1 +1))
          (dolist (order '((0 1 2) (0 2 1) (1 0 2)
                           (1 2 0) (2 1 0) (2 0 1)))
            (push (make-configuration (list sx sy sz) order)
                  configurations)))))
    configurations))

(defvar *configurations*
  (make-configurations))

(defun apply-configuration (configuration beacon)
  (funcall configuration beacon))

(defun find-relative-position (s1 b1 c1 s2 b2)
  (let ((o1 (mapcar (lambda (b) (apply-configuration c1 (beacon- b b1)))
                    (scanner-beacons s1))))
    (loop for configuration in *configurations*
          for b2-ref = (apply-configuration configuration b2)
          for o2 = (mapcar (lambda (b) (beacon- (apply-configuration configuration b) b2-ref))
                           (scanner-beacons s2))
          when (>= (length (intersection o1 o2 :test #'equal)) 12)
          do (return-from find-relative-position
               (values (beacon- (apply-configuration c1 b1) b2-ref) configuration)))))

(defun find-relative-positions (scanners)
  (let* ((candidates (find-candidates scanners))
         (positions-relative-to-s0 (make-array (length scanners) :initial-element nil))
         (configurations (make-array (length scanners) :initial-element nil)))
    (setf (aref positions-relative-to-s0 0) '(0 0 0))
    (setf (aref configurations 0) (make-configuration '(+1 +1 +1) '(0 1 2)))
    (loop until (null candidates)
          do (destructuring-bind (s1 b1 s2 b2) (pop candidates)
               (when (null (aref positions-relative-to-s0 (scanner-number s1)))
                 (rotatef s1 s2)
                 (rotatef b1 b2))
               (if (null (aref positions-relative-to-s0 (scanner-number s1)))
                   (setf candidates (append candidates (list (list s1 b1 s2 b2))))
                   (when (null (aref positions-relative-to-s0 (scanner-number s2)))
                     (let ((c1 (aref configurations (scanner-number s1))))
                       (multiple-value-bind (position-relative-to-s1 configuration)
                           (find-relative-position s1 b1 c1 s2 b2)
                         (setf (aref positions-relative-to-s0 (scanner-number s2))
                               (beacon+ position-relative-to-s1
                                        (aref positions-relative-to-s0 (scanner-number s1))))
                         (setf (aref configurations (scanner-number s2))
                               configuration)
                         (let ((candidates-containing-s2
                                 (loop for candidate in candidates
                                       when (member s2 candidate)
                                       collect candidate)))
                           (setf candidates
                                 (append candidates-containing-s2
                                         (set-difference candidates candidates-containing-s2))))))))))
    (values positions-relative-to-s0 configurations)))

(defun count-beacons (scanners positions configurations)
  (let ((beacons (make-hash-table :test 'equal)))
    (loop for scanner in scanners
          for position across positions
          for configuration across configurations
          do (dolist (beacon (scanner-beacons scanner))
               (let ((beacon (apply-configuration configuration beacon)))
                 (setf (gethash (beacon+ beacon position) beacons) t))))
    (hash-table-count beacons)))

(defun largest-distance (positions)
  (do ((d 0)
       (i 0 (1+ i)))
      ((= i (length positions)) d)
    (do ((j (1+ i) (1+ j)))
        ((= j (length positions)))
      (setf d (max d (beacon-norm (beacon- (aref positions i) (aref positions j))))))))

(defun day19 (input)
  (let ((scanners (parse input)))
    (multiple-value-bind (positions configurations)
        (find-relative-positions scanners)
      (list (count-beacons scanners positions configurations)
            (largest-distance positions)))))