day-22.lisp (6142B)
1 (defpackage #:aoc/day-22 2 (:use #:cl #:aoc/utils) 3 (:export #:day-22)) 4 (in-package #:aoc/day-22) 5 6 (defclass sand-block () 7 ((p-1 8 :initarg :p-1 9 :reader sand-block-p-1) 10 (p-2 11 :initarg :p-2 12 :reader sand-block-p-2))) 13 14 (defun make-sand-block (p-1 p-2) 15 (make-instance 'sand-block :p-1 p-1 :p-2 p-2)) 16 17 (defmethod print-object ((block sand-block) stream) 18 (print-unreadable-object (block stream :type t) 19 (with-slots (id p-1 p-2) 20 block 21 (format stream "~A: ~A ~A" id p-1 p-2)))) 22 23 (declaim (ftype (function (sand-block) fixnum) 24 sand-block-bottom-z 25 sand-block-top-z) 26 (ftype (function (fixnum sand-block) fixnum) 27 (setf sand-block-bottom-z) 28 (setf sand-block-top-z)) 29 (inline sand-block-bottom-z sand-block-top-z 30 (setf sand-block-bottom-z) (setf sand-block-top-z))) 31 32 (defun sand-block-bottom-z (block) 33 (third (sand-block-p-1 block))) 34 35 (defun (setf sand-block-bottom-z) (new-z block) 36 (setf (third (sand-block-p-1 block)) new-z)) 37 38 (defun sand-block-top-z (block) 39 (third (sand-block-p-2 block))) 40 41 (defun (setf sand-block-top-z) (new-z block) 42 (setf (third (sand-block-p-2 block)) new-z)) 43 44 (declaim (ftype (function (simple-string) sand-block) parse-line)) 45 (defun parse-line (line) 46 (loop with p-1 = (list 0 0 0) 47 with p-2 = (list 0 0 0) 48 for current-index in (list 0 1 2 49 0 1 2) 50 for obj in (list p-1 p-1 p-1 51 p-2 p-2 p-2) 52 for pos from 0 below (length line) 53 do (multiple-value-bind (n end) 54 (parse-integer line :start pos :junk-allowed t) 55 (setf (nth current-index obj) n) 56 (setf pos end)) 57 finally (return (make-sand-block p-1 p-2)))) 58 59 (defun parse-input (input) 60 (loop for line = (read-line input nil) 61 while line 62 collect (parse-line line))) 63 64 (defun collides-p (block-1 block-2) 65 (labels ((intersects-p (from-1 to-1 from-2 to-2) 66 (declare (type fixnum from-1 to-1 from-2 to-2)) 67 (and (<= from-1 to-2) 68 (<= from-2 to-1)))) 69 (let ((b1-p1 (sand-block-p-1 block-1)) 70 (b1-p2 (sand-block-p-2 block-1)) 71 (b2-p1 (sand-block-p-1 block-2)) 72 (b2-p2 (sand-block-p-2 block-2))) 73 (and (intersects-p (first b1-p1) (first b1-p2) (first b2-p1) (first b2-p2)) 74 (intersects-p (second b1-p1) (second b1-p2) (second b2-p1) (second b2-p2)))))) 75 76 (defun find-collision (block others) 77 (first (sort (loop for other in others 78 when (collides-p block other) 79 collect other) 80 #'> 81 :key #'sand-block-top-z))) 82 83 (defun apply-gravity (blocks) 84 (loop for i from 0 85 for block in blocks 86 for others = (nreverse (subseq blocks 0 i)) 87 for collision = (find-collision block others) 88 for new-z = (or (and collision 89 (1+ (sand-block-top-z collision))) 90 1) 91 do (decf (sand-block-top-z block) 92 (- (sand-block-bottom-z block) new-z)) 93 do (setf (sand-block-bottom-z block) new-z) 94 finally (return blocks))) 95 96 (defun block-rests-on (block others) 97 (loop with resting-z = (1- (sand-block-bottom-z block)) 98 for other in others 99 when (and (= (sand-block-top-z other) resting-z) 100 (collides-p block other)) 101 collect other)) 102 103 (defun blocks-resting-on (block others) 104 (loop with resting-z = (1+ (sand-block-top-z block)) 105 for other in others 106 when (and (= (sand-block-bottom-z other) resting-z) 107 (collides-p block other)) 108 collect other)) 109 110 (defun task-1 (blocks) 111 (loop with safe-to-disintegrate = (make-hash-table) 112 for (block . others) on blocks 113 for resting-on = (block-rests-on block others) 114 when (= (length resting-on) 1) 115 do (setf (gethash (first resting-on) safe-to-disintegrate) t) 116 finally (return (loop for block in blocks 117 when (not (gethash block safe-to-disintegrate)) 118 sum 1)))) 119 120 (defun task-2 (blocks) 121 (let ((c-block-rests-on (make-hash-table)) 122 (c-blocks-resting-on (make-hash-table))) 123 (labels ((c-block-rests-on (block) 124 (or (gethash block c-block-rests-on) 125 (setf (gethash block c-block-rests-on) 126 (block-rests-on block blocks)))) 127 (c-blocks-resting-on (block) 128 (or (gethash block c-blocks-resting-on) 129 (setf (gethash block c-blocks-resting-on) 130 (blocks-resting-on block blocks)))) 131 (unsupported-p (block destroyed) 132 (let* ((rests-on (c-block-rests-on block)) 133 (rests-on (remove-if (lambda (block) 134 (gethash block destroyed)) 135 rests-on))) 136 (null rests-on))) 137 (destroy (layer &optional (destroyed (make-hash-table))) 138 (loop for block in layer 139 do (setf (gethash block destroyed) t)) 140 (let ((next-layer (loop with result = (make-hash-table) 141 for block in layer 142 do (loop for resting-on in (c-blocks-resting-on block) 143 when (unsupported-p resting-on destroyed) 144 do (setf (gethash resting-on result) t)) 145 finally (return (hash-table-keys result))))) 146 (+ (length layer) 147 (if next-layer (destroy next-layer destroyed) 0))))) 148 (loop for block in blocks 149 sum (max 0 (1- (destroy (list block)))))))) 150 151 (defun day-22 (input) 152 (let* ((blocks (parse-input input)) 153 (blocks (sort blocks #'< :key #'sand-block-bottom-z)) 154 (blocks (apply-gravity blocks))) 155 (values (task-1 (reverse blocks)) 156 (task-2 blocks))))