Refactor 2023/22

- Use DEFINE-SOLUTION / DEFINE-TEST
- Use new ADJOIN! support to LOOPING
- Extract BRICKS-FREE-TOO-MOVE to avoid some copy pasta between part
  1 and part 2

src/2023/day22.lisp

@@ -2,58 +2,77 @@
 (in-package :aoc/2023/22)
 
 
-(defvar *name* #\A)
-(defun brick (s)
-  (prog1 (append (extract-positive-integers s) (list (as-keyword *name*)))
-    (setf *name* (code-char (1+ (char-code *name*))))))
-#+#:excluded (brick "1,0,1~1,2,1")
-
-(defun parse-input (&optional (strings (uiop:read-file-lines #P"src/2023/day22.txt")))
-  (setf *name* #\A)
-  (mapcar #'brick strings))
-#+#:excluded (parse-input)
+(defun brick (s) (extract-positive-integers s))
+(defaccessor x1 (b) (accesses (nth 0 b)))
+(defaccessor y1 (b) (accesses (nth 1 b)))
+(defaccessor z1 (b) (accesses (nth 2 b)))
+(defaccessor x2 (b) (accesses (nth 3 b)))
+(defaccessor y2 (b) (accesses (nth 4 b)))
+(defaccessor z2 (b) (accesses (nth 5 b)))
+
+(defparameter *debug-names* nil)
+
+(defun parse-input (&optional (strings (aoc::read-problem-input 2023 22)))
+  (bnd1 (bricks (mapcar #'brick strings))
+    (if-not *debug-names*
+      bricks
+      (bnd1 (name #\A)
+        (looping
+          (doseq (b bricks)
+            (collect! (append b (list (as-keyword name))) )
+            (setf name (code-char (1+ (char-code name))))))))))
 
 
 (defun index-by-z (&optional (bricks (parse-input)))
   (bnd1 (index (make-hash-table :test 'eql))
     (dolist (b bricks)
-      (dorangei (z (third b) (sixth b))
-        (push b (gethash z index))))
+      (add-to-index index b))
     index))
-#+#:excluded (index-by-z)
+
+(defun add-to-index (index b)
+  (dorangei (z (z1 b) (z2 b))
+    (push b (gethash z index)))
+  index)
+
+(defun remove-from-index (index b)
+  (dorangei (z (z1 b) (z2 b))
+    (removef (gethash z index) b :test #'equal))
+  index)
 
 
 (defun can-move-down? (b index)
   (and (not (on-the-ground? b))
        (not (blocked? b index))))
 
 
-(defun on-the-ground? (b) (= (third b) 1)) ; TODO should we check SIXTH too?
+(defun on-the-ground? (b) (= (z1 b) 1)) ; TODO should we check Z2 too?
 
 
-(defun move-down (b)
-  (destructuring-bind (x1 y1 z1 x2 y2 z2) (butlast b)
-    (list* x1 y1 (1- z1) x2 y2 (1- z2) (last b))))
-
-
-(defun ranges-overlap? (s1 e1 s2 e2)
-  ; (assert (and (<= s1 e1) (<= s2 e2)))
-  (and (<= s1 e2) (>= e1 s2)))
-
-(defun bricks-overlap? (b1 b2)
-  (and (ranges-overlap? (first b1) (fourth b1) (first b2) (fourth b2))
-       (ranges-overlap? (second b1) (fifth b1) (second b2) (fifth b2))
-       (ranges-overlap? (third b1) (sixth b1) (third b2) (sixth b2))))
-
 (defun blocked? (b index)
   (bnd1 (b- (move-down b))
-    (dorangei (z (third b-) (sixth b-))
+    (dorangei (z (z1 b-) (z2 b-))
       (dolist (b1 (gethash z index))
         (unless (equal b b1)
           (when (bricks-overlap? b- b1)
             (return-from blocked? b1)))))))
 
 
+(defun move-down (b) (move-down! (copy-seq b)))
+
+(defun move-down! (b)
+  (prog1 b
+    (decf (z1 b))
+    (decf (z2 b))))
+
+(defun bricks-overlap? (b1 b2)
+  (and (ranges-overlap? (x1 b1) (x2 b1) (x1 b2) (x2 b2))
+       (ranges-overlap? (y1 b1) (y2 b1) (y1 b2) (y2 b2))
+       (ranges-overlap? (z1 b1) (z2 b1) (z1 b2) (z2 b2))))
+
+(defun ranges-overlap? (s1 e1 s2 e2)
+  (and (<= s1 e2) (>= e1 s2)))
+
+
 (defun free-fall (&optional (bricks (parse-input)))
   (bnd* ((index (index-by-z bricks))
          (continue? t))
@@ -62,57 +81,39 @@
       (dolist (z (sort (hash-table-keys index) #'<))
         (dolist (b (gethash z index))
           (while (can-move-down? b index)
-            (removef (gethash (sixth b) index) b :test #'equal)
-            (decf (sixth b))
-            (decf (third b))
-            (push b (gethash (third b) index))
+            (remove-from-index index b)
+            (add-to-index index (move-down! b))
             (setf continue? t)))))
     index))
-#+#:excluded (free-fall)
-#+#:excluded (hash-table-alist *)
 
 
-(defun disintegrateable? (b index)
+(defun safe-to-disintegrate? (b index)
   (setf index (copy-hash-table index))
-  (dorangei (z (third b) (sixth b))
-    (removef (gethash z index) b :test #'equal))
-  (dorangei (z (third b) (1+ (sixth b))) ; 1+ because we want to process anything above
-    (dolist (b1 (gethash z index))
-      (assert (not (equal b1 b)))
-      (when (can-move-down? b1 index)
-        (return-from disintegrateable? nil))))
-  t)
-
-(defun part1 (&optional (bricks (parse-input)))
-  (bnd1 (index (free-fall bricks))
-    (count-if [disintegrateable? _ index] bricks)))
-#+#:excluded (part1)
-; 482 too low -- also same answer for someone else
-; 1428 too high
-; 1429 too high -- lol
-; 1412
-; 485
+  (remove-from-index index b)
+  (not (bricks-free-to-move index (z1 b) (1+ (z2 b)))))  ; 1+ because we want to process anything above the removed brick
+
+(defun bricks-free-to-move (index z1 z2)
+  (looping
+    (dorangei (z z1 z2)
+      (dolist (b1 (gethash z index))
+        (when (can-move-down? b1 index)
+          (adjoin! b1 :test #'equal))))))
 
 
-(defun disintegrate (b index)
+(defun disintegrate-and-count-fallen (index b)
   (setf index (copy-hash-table index))
-  (bnd1 (fallen nil)
-    (labels ((recur (b)
-               (dorangei (z (third b) (sixth b))
-                 (removef (gethash z index) b :test #'equal))
-               (dorangei (z (third b) (1+ (sixth b))) ; 1+ because we want to process anything above
-                 (dolist (b1 (gethash z index))
-                   (assert (not (equal b1 b)))
-                   (when (can-move-down? b1 index)
-                     (push b1 fallen)
-                     (recur b1))))))
-      (recur b)
-      (length (remove-duplicates fallen :test #'equal)))))
-
-
-(defun part2 (&optional (bricks (parse-input)))
+  (length
+    (looping
+      (recursively ((b b))
+        (remove-from-index index b)
+        (dolist (b1 (bricks-free-to-move index (z1 b) (1+ (z2 b)))) ; 1+ because we want to process anything above the removed brick
+          (adjoin! b1)
+          (recur b1))))))
+
+
+(define-solution (2023 22) (bricks parse-input)
   (bnd1 (index (free-fall bricks))
-    (reduce #'+ bricks :key [disintegrate _ index])))
-#+#:excluded (part2)
-; 324269 too high
-; 74594
+    (values (count-if [safe-to-disintegrate? _ index] bricks)
+            (reduce #'+ bricks :key [disintegrate-and-count-fallen index _]))))
+
+(define-test (2023 22) (485 74594))

vendor/make-quickutils.lisp

@@ -26,6 +26,7 @@
                :bnd1
                :copy-array
                :copy-hash-table
+               :defaccessor
                :digits
                :divf
                :doalist
@@ -52,6 +53,7 @@
                :ncycle
                :plist-keys
                :plist-values
+               :pr
                :recursively
                :removef
                :repeat