aoc2020 day20

aoc2020-day20.lisp

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

(defpackage #:snippets/aoc2020/day20
  (:use #:cl)
  (:shadowing-import-from
   #:fset
   #:empty-map
   #:with
   #:lookup
   #:size
   #:includef)
  (:import-from
   #:alexandria
   #:first-elt
   #:last-elt)
  (:shadowing-import-from
   #:screamer
   #:defun
   #:multiple-value-bind
   #:assert!
   #:one-value
   #:a-member-of
   #:fail)
  (:export
   #:day20))

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

(defstruct (tile
            (:print-function print-tile))
  id
  vid
  top
  bottom
  left
  right
  raw)

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

(defun print-tile (tile stream depth)
  (declare (ignore depth))
  (format stream "#<~S ~A>"
          (type-of tile)
          (tile-vid tile)))

(defun parse-tile (strings)
  (let ((vid (subseq (first strings) 5 (1- (length (first strings))))))
    (make-tile :id (parse-integer vid)
               :vid vid
               :top (second strings)
               :bottom (last-elt strings)
               :left (map 'string #'first-elt (rest strings))
               :right (map 'string #'last-elt (rest strings))
               :raw (lambda () (remove-borders (rest strings))))))

(defun hflip (tile)
  (make-tile :id (tile-id tile)
             :vid `(hflip ,(tile-vid tile))
             :top (reverse (tile-top tile))
             :bottom (reverse (tile-bottom tile))
             :left (tile-right tile)
             :right (tile-left tile)
             :raw (let ((raw (tile-raw tile)))
                    (lambda () (hflip-strings (funcall raw))))))

(defun vflip (tile)
  (make-tile :id (tile-id tile)
             :vid `(vflip ,(tile-vid tile))
             :top (tile-bottom tile)
             :bottom (tile-top tile)
             :left (reverse (tile-left tile))
             :right (reverse (tile-right tile))
             :raw (let ((raw (tile-raw tile)))
                    (lambda () (vflip-strings (funcall raw))))))

(defun rotl (tile)
  (make-tile :id (tile-id tile)
             :vid (let ((deg 90)
                        (vid (tile-vid tile)))
                    (when (and (consp vid) (eq (car vid) 'rot))
                      (incf deg (cadr vid))
                      (setf vid (caddr vid)))
                    `(rot ,deg ,vid))
             :top (tile-right tile)
             :bottom (tile-left tile)
             :left (reverse (tile-top tile))
             :right (reverse (tile-bottom tile))
             :raw (let ((raw (tile-raw tile)))
                    (lambda () (rotl-strings (funcall raw))))))

(defun expand-tile (tile)
  (let* ((h (hflip tile))
         (v (vflip tile))
         (r1 (rotl tile))
         (r2 (rotl r1))
         (r3 (rotl r2)))
    (list tile h v r1 r2 r3 (hflip r1) (vflip r1))))

(defun expand-tiles (tiles)
  (mapcan #'expand-tile tiles))

(defstruct index
  (id (empty-map))
  (right (empty-map))
  (bottom (empty-map)))

(defun index-variants (variants)
  (let ((index (make-index)))
    (dolist (variant variants)
      (includef (index-id index)
                (tile-id variant)
                (cons variant
                      (lookup (index-id index)
                              (tile-id variant))))
      (includef (index-right index)
                (tile-right variant)
                (cons variant
                      (lookup (index-right index)
                              (tile-right variant))))
      (includef (index-bottom index)
                (tile-bottom variant)
                (cons variant
                      (lookup (index-bottom index)
                              (tile-bottom variant)))))
    index))

(defun compatible-left (index right)
  (lookup (index-right index) (tile-left right)))

(defun compatible-top (index bottom)
  (lookup (index-bottom index) (tile-top bottom)))

(defun assemble (tiles)
  (let* ((side (isqrt (length tiles)))
         (variants (expand-tiles tiles))
         (index (index-variants variants))
         (ids (mapcar #'tile-id tiles)))
    (assemble-1 index side 0 ids (empty-map))))

(defun assemble-1 (index side position ids arrangement)
  (if (null ids)
      arrangement
      (let ((id (a-member-of ids)))
        (let* ((variants (lookup (index-id index) id))
               (variant (a-member-of variants)))
          (multiple-value-bind (i j) (truncate position side)
            (when (plusp j)
              (let ((left (lookup arrangement (- position 1))))
                (unless (member left (compatible-left index variant))
                  (fail))))
            (when (plusp i)
              (let ((top (lookup arrangement (- position side))))
                (unless (member top (compatible-top index variant))
                  (fail))))
            (assemble-1 index
                        side
                        (1+ position)
                        (remove id ids :count 1)
                        (with arrangement position variant)))))))

(defun corners (arrangement)
  (let* ((side (isqrt (size arrangement)))
         (m (1- side)))
    (list (lookup arrangement (+ (* 0 side) 0))
          (lookup arrangement (+ (* m side) 0))
          (lookup arrangement (+ (* 0 side) m))
          (lookup arrangement (+ (* m side) m)))))

(defun product (sequence &key (key #'identity))
  (reduce #'* sequence :key key))

(defun remove-borders (strings)
  (mapcar (lambda (string)
            (subseq string 1 (1- (length string))))
          (butlast (rest strings))))

(defun hflip-strings (strings)
  (map (if (vectorp strings)
           'vector
           'list)
       #'reverse
       strings))

(defun vflip-strings (strings)
  (reverse strings))

(defun rotl-strings (strings)
  (let ((result
          (loop for i downfrom (1- (length (first-elt strings))) to 0
                collect (map 'string (lambda (string) (char string i)) strings))))
    (if (vectorp strings)
        (coerce result 'vector)
        result)))

(defun make-image (arrangement)
  (let* ((side (isqrt (size arrangement)))
         (image nil)
         (slen 0))
    (dotimes (i side)
      (dotimes (j side)
        (let* ((variant (lookup arrangement (+ (* i side) j)))
               (strings (funcall (tile-raw variant))))
          (when (null image)
            (setf slen (length strings))
            (assert (= slen (length (first strings))))
            (setf image (make-array (* slen side) :initial-element nil)))
          (loop for k upfrom 0
                for string in strings
                for ik = (+ (* i slen) k)
                for output = (or (aref image ik)
                                 (setf (aref image ik)
                                       (make-string (* slen side))))
                do (loop for l upfrom 0
                         for char across string
                         do (setf (aref output (+ (* j slen) l)) char))))))
    image))

(defun compile-pattern (pattern)
  (let ((result '()))
    (loop for i upfrom 0
          for string in pattern
          do (loop for j upfrom 0
                   for char across string
                   when (char= char #\#)
                   do (push (list i j) result)))
    result))

(defvar *sea-monster*
  (compile-pattern
   '("                  # "
     "#    ##    ##    ###"
     " #  #  #  #  #  #   ")))

(defun find-pattern (image pattern)
  (let ((result '()))
    (dotimes (i (length image))
      (dotimes (j (length (first-elt image)))
        (when (match-pattern image i j pattern)
          (push (list i j) result))))
    result))

(defun match-pattern (image mi mj pattern)
  (loop for (di dj) in pattern
        for i = (+ mi di)
        for j = (+ mj dj)
        always (and (<= 0 i (1- (length image)))
                    (<= 0 j (1- (length (first-elt image))))
                    (char= (char (aref image i) j) #\#))))

(defun expand-image (image)
  (let* ((id (map 'vector #'copy-seq image))
         (h (hflip-strings image))
         (v (vflip-strings image))
         (r1 (rotl-strings image))
         (r2 (rotl-strings r1))
         (r3 (rotl-strings r2)))
    (list id h v r1 r2 r3 (hflip-strings r1) (vflip-strings r1))))

(defun clear-pattern (image ci cj pattern)
  (loop for (di dj) in pattern
        for i = (+ ci di)
        for j = (+ cj dj)
        when (and (<= 0 i (1- (length image)))
                  (<= 0 j (1- (length (first-elt image)))))
        do (setf (aref (aref image i) j) #\.)))

(defun show (image &optional slen)
  (loop for i upfrom 0
        for string across (coerce image 'vector)
        do (when (and slen (zerop (mod i slen)))
             (terpri))
           (loop for j upfrom 0
                 for char across string
                 do (when (and slen (zerop (mod j slen)))
                      (write-char #\Space))
                    (write-char char))
           (terpri))
  (terpri))

(defun find-sea-monsters (image)
  (mapcar (lambda (image-variant)
            (find-pattern image-variant *sea-monster*))
          (expand-image image)))

(defun sum (sequence &key (key #'identity))
  (reduce #'+ sequence :key key))

(defun clear-sea-monsters (image)
  (dolist (image-variant (expand-image image))
    (let ((positions (find-pattern image-variant *sea-monster*)))
      (when positions
        (loop for (i j) in positions
              do (clear-pattern image-variant i j *sea-monster*))
        (return-from clear-sea-monsters image-variant))))
  (warn "No sea monsters in image.")
  image)

(defun roughness (image)
  (sum (clear-sea-monsters image)
       :key (lambda (string) (count #\# string))))

(defun day20 (input)
  (let* ((tiles (parse input))
         (arrangement (one-value (assemble tiles))))
    (list (product (corners arrangement) :key #'tile-id)
          (roughness (make-image arrangement)))))