commit ce60b45a738eb442af4a85b4cee06d5948941272
parent f79571f7ca069e3ac1deb706941bfd32e705a34f
Author: Lukas Henkel <lh@entf.net>
Date: Fri, 22 Dec 2023 17:16:06 +0100
Day 22 task 2
Diffstat:
2 files changed, 62 insertions(+), 16 deletions(-)
diff --git a/src/day-22.lisp b/src/day-22.lisp
@@ -4,21 +4,23 @@
(in-package #:aoc/day-22)
(defclass sand-block ()
- ((p-1
+ ((id
+ :initarg :id)
+ (p-1
:initarg :p-1
:reader sand-block-p-1)
(p-2
:initarg :p-2
:reader sand-block-p-2)))
-(defun make-sand-block (p-1 p-2)
- (make-instance 'sand-block :p-1 p-1 :p-2 p-2))
+(defun make-sand-block (id p-1 p-2)
+ (make-instance 'sand-block :id id :p-1 p-1 :p-2 p-2))
(defmethod print-object ((block sand-block) stream)
(print-unreadable-object (block stream :type t)
- (with-slots (p-1 p-2)
+ (with-slots (id p-1 p-2)
block
- (format stream "~A ~A" p-1 p-2))))
+ (format stream "~A: ~A ~A" id p-1 p-2))))
(defmethod sand-block-bottom-z ((block sand-block))
(with-slots (p-1)
@@ -40,7 +42,7 @@
block
(setf (third p-2) new-z)))
-(defun parse-line (line)
+(defun parse-line (line index)
(loop with p-1 = (list 0 0 0)
with p-2 = (list 0 0 0)
for current-index in (list 0 1 2
@@ -52,12 +54,13 @@
(parse-integer line :start pos :junk-allowed t)
(setf (nth current-index obj) n)
(setf pos end))
- finally (return (make-sand-block p-1 p-2))))
+ finally (return (make-sand-block (code-char (+ index 65)) p-1 p-2))))
(defun parse-input (input)
(loop for line = (read-line input nil)
+ for i from 0
while line
- collect (parse-line line)))
+ collect (parse-line line i)))
(defun collides-p (block-1 block-2)
(labels ((intersects-p (from-1 to-1 from-2 to-2)
@@ -90,22 +93,64 @@
do (setf (sand-block-bottom-z block) new-z)
finally (return blocks)))
+(defun block-rests-on (block others)
+ (loop with resting-z = (1- (sand-block-bottom-z block))
+ for other in others
+ when (and (= (sand-block-top-z other) resting-z)
+ (collides-p block other))
+ collect other))
+
+(defun blocks-resting-on (block others)
+ (loop with resting-z = (1+ (sand-block-top-z block))
+ for other in others
+ when (and (= (sand-block-bottom-z other) resting-z)
+ (collides-p block other))
+ collect other))
+
(defun task-1 (blocks)
(loop with safe-to-disintegrate = (make-hash-table)
for (block . others) on blocks
- for resting-z = (1- (sand-block-bottom-z block))
- for resting-on = (loop for other in others
- when (and (= (sand-block-top-z other) resting-z)
- (collides-p block other))
- collect other)
+ for resting-on = (block-rests-on block others)
when (= (length resting-on) 1)
do (setf (gethash (first resting-on) safe-to-disintegrate) t)
finally (return (loop for block in blocks
when (not (gethash block safe-to-disintegrate))
sum 1))))
+(defun task-2 (blocks)
+ (let ((c-block-rests-on (make-hash-table))
+ (c-blocks-resting-on (make-hash-table)))
+ (labels ((c-block-rests-on (block)
+ (or (gethash block c-block-rests-on)
+ (setf (gethash block c-block-rests-on)
+ (block-rests-on block blocks))))
+ (c-blocks-resting-on (block)
+ (or (gethash block c-blocks-resting-on)
+ (setf (gethash block c-blocks-resting-on)
+ (blocks-resting-on block blocks))))
+ (unsupported-p (block destroyed)
+ (let* ((rests-on (c-block-rests-on block))
+ (rests-on (remove-if (lambda (block)
+ (gethash block destroyed))
+ rests-on)))
+ (null rests-on)))
+ (destroy (layer &optional (destroyed (make-hash-table)))
+ (loop for block in layer
+ do (setf (gethash block destroyed) t))
+ (let ((next-layer (loop with result = (make-hash-table)
+ for block in layer
+ do (loop for resting-on in (c-blocks-resting-on block)
+ when (unsupported-p resting-on destroyed)
+ do (setf (gethash resting-on result) t))
+ finally (return (hash-table-keys result)))))
+ (+ (length layer)
+ (if next-layer (destroy next-layer destroyed) 0)))))
+ (loop for block in blocks
+ sum (max 0 (1- (destroy (list block))))))))
+
(defun day-22 (input)
(let* ((blocks (parse-input input))
(blocks (sort blocks #'< :key #'sand-block-bottom-z))
(blocks (apply-gravity blocks)))
- (task-1 (nreverse blocks))))
+ (values (task-1 (reverse blocks))
+ (task-2 blocks))))
diff --git a/t/day-22.lisp b/t/day-22.lisp
@@ -4,7 +4,7 @@
(define-test test-day-22
()
- (multiple-value-bind (task-1)
+ (multiple-value-bind (task-1 task-2)
(aoc:run-day 22 "1,0,1~1,2,1
0,0,2~2,0,2
0,2,3~2,2,3
@@ -12,4 +12,5 @@
2,0,5~2,2,5
0,1,6~2,1,6
1,1,8~1,1,9")
- (assert= 5 task-1)))
+ (assert= 5 task-1)
+ (assert= 7 task-2)))
