aoc2020 day14

aoc2020-day14.lisp

;;;; +----------------------------------------------------------------+
;;;; | Advent of Code 2020                                            |
;;;; +----------------------------------------------------------------+

(defpackage #:snippets/aoc2020/day14
  (:use #:cl)
  (:import-from
   #:split-sequence
   #:split-sequence-if)
  (:import-from
   #:alexandria
   #:destructuring-ecase)
  (:export
   #:day14))

(in-package #:snippets/aoc2020/day14)

(defun parse (input)
  (mapcar #'parse-instruction input))

(defun parse-instruction (string)
  (let ((tokens (split-sequence-if (lambda (char) (find char " =[]"))
                                   string
                                   :remove-empty-subseqs t)))
    (cond ((equal (first tokens) "mask")
           (list :mask
                 (decode-mask (second tokens))))
          ((equal (first tokens) "mem")
           (list :mem
                 (parse-integer (second tokens))
                 (parse-integer (third tokens))))
          (t
           (error "Unexpected instruction string ~S." string)))))

(defun decode-mask (string)
  (assert (= (length string) 36))
  (loop with mask = (make-list 3)
        for char across string
        for i downfrom 35
        for j = (ecase char
                  (#\0 0)
                  (#\1 1)
                  (#\X 2))
        do (push i (nth j mask))
        finally (return mask)))

(defun apply-mask (value mask)
  (destructuring-bind (zeros ones xs) mask
    (declare (ignore xs))
    (deposit-many-bits 1 ones (deposit-many-bits 0 zeros value))))

(defun deposit-many-bits (new-bit positions initial-value)
  (reduce (lambda (value position)
            (dpb new-bit (byte 1 position) value))
          positions
          :initial-value initial-value))

(defun map-memory-addresses (function original-address mask)
  (destructuring-bind (zeros ones xs) mask
    (declare (ignore zeros))
    (let ((fixed-ones-address (deposit-many-bits 1 ones original-address)))
      (dotimes (bits (ash 1 (length xs)))
        (let ((address fixed-ones-address))
          (loop for i upfrom 0
                for new-bit = (ldb (byte 1 i) bits)
                for j in xs
                do (setf (ldb (byte 1 j) address) new-bit))
          (funcall function address))))))

(defmacro do-memory-addresses ((var address mask) &body forms)
  `(block nil
     (map-memory-addresses (lambda (,var) ,@forms) ,address ,mask)))

(defun run (instructions version)
  (let ((memory (make-hash-table))
        (mask (make-list 3)))
    (dolist (instruction instructions)
      (destructuring-ecase instruction
        ((:mask m)
         (setf mask m))
        ((:mem i v)
         (ecase version
           (1 (setf (gethash i memory) (apply-mask v mask)))
           (2 (do-memory-addresses (j i mask)
                (setf (gethash j memory) v)))))))
    memory))

(defun memsum (memory)
  (loop for value being each hash-value of memory
        sum value))

(defun day14 (input)
  (let ((instructions (parse input)))
    (list (memsum (run instructions 1))
          (memsum (run instructions 2)))))