From 198ba09becf30906a75823f659a717335048f89d Mon Sep 17 00:00:00 2001 From: Matteo Landi Date: Thu, 1 Feb 2024 08:42:26 +0100 Subject: [PATCH] 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 | 149 ++++++++++++++++++------------------ vendor/make-quickutils.lisp | 1 + vendor/quickutils.lisp | 118 ++++++++++++++++++++++------ 3 files changed, 171 insertions(+), 97 deletions(-) diff --git a/src/2023/day22.lisp b/src/2023/day22.lisp index 041c52e..a7cdf52 100644 --- a/src/2023/day22.lisp +++ b/src/2023/day22.lisp @@ -2,25 +2,42 @@ (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) @@ -28,32 +45,34 @@ (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)) diff --git a/vendor/make-quickutils.lisp b/vendor/make-quickutils.lisp index d967753..62363bc 100644 --- a/vendor/make-quickutils.lisp +++ b/vendor/make-quickutils.lisp @@ -26,6 +26,7 @@ :bnd1 :copy-array :copy-hash-table + :defaccessor :digits :divf :doalist diff --git a/vendor/quickutils.lisp b/vendor/quickutils.lisp index 0fe1aa5..7a2bd78 100644 --- a/vendor/quickutils.lisp +++ b/vendor/quickutils.lisp @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:KEEP-IF :KEEP-IF-NOT :AAND :AIF :ALIST-KEYS :ALIST-VALUES :ASSOC-VALUE :AWHEN :BND* :BND1 :COPY-ARRAY :COPY-HASH-TABLE :DIGITS :DIVF :DOALIST :DOHASH :DOLISTS :DORANGE :DORANGEI :DOSEQ :DOSEQS :DOSUBLISTS :ENUMERATE :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-KEYS :HASH-TABLE-VALUES :IF-LET :IF-NOT :IOTA :LOOPING :MAKE-KEYWORD :MKSTR :MULF :NCYCLE :PLIST-KEYS :PLIST-VALUES :RECURSIVELY :REMOVEF :REPEAT :STRING-ENDS-WITH-P :STRING-STARTS-WITH-P :SUBDIVIDE :SUBSEQ- :SYMB :VOID :WHEN-LET :WHEN-NOT :WHILE :WHILE-NOT :WITH-GENSYMS :SHUFFLE :RANDOM-ELT :XOR) :ensure-package T :package "AOC.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:KEEP-IF :KEEP-IF-NOT :AAND :AIF :ALIST-KEYS :ALIST-VALUES :ASSOC-VALUE :AWHEN :BND* :BND1 :COPY-ARRAY :COPY-HASH-TABLE :DEFACCESSOR :DIGITS :DIVF :DOALIST :DOHASH :DOLISTS :DORANGE :DORANGEI :DOSEQ :DOSEQS :DOSUBLISTS :ENUMERATE :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-KEYS :HASH-TABLE-VALUES :IF-LET :IF-NOT :IOTA :LOOPING :MAKE-KEYWORD :MKSTR :MULF :NCYCLE :PLIST-KEYS :PLIST-VALUES :RECURSIVELY :REMOVEF :REPEAT :STRING-ENDS-WITH-P :STRING-STARTS-WITH-P :SUBDIVIDE :SUBSEQ- :SYMB :VOID :WHEN-LET :WHEN-NOT :WHILE :WHILE-NOT :WITH-GENSYMS :SHUFFLE :RANDOM-ELT :XOR) :ensure-package T :package "AOC.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "AOC.QUICKUTILS") @@ -17,11 +17,12 @@ :AAND :ALIST-KEYS :ALIST-VALUES :STRING-DESIGNATOR :WITH-GENSYMS :ASSOC-VALUE :AWHEN :BND* :BND1 - :COPY-ARRAY :COPY-HASH-TABLE :DIGITS - :DIVF :MAKE-GENSYM-LIST :ONCE-ONLY - :DOALIST :DOHASH :DOLISTS :DORANGE - :DORANGEI :DOSEQ :DOSEQS :DOSUBLISTS - :ENUMERATE :FLATTEN :HASH-TABLE-ALIST + :COPY-ARRAY :COPY-HASH-TABLE + :PARSE-BODY :DEFACCESSOR :DIGITS :DIVF + :MAKE-GENSYM-LIST :ONCE-ONLY :DOALIST + :DOHASH :DOLISTS :DORANGE :DORANGEI + :DOSEQ :DOSEQS :DOSUBLISTS :ENUMERATE + :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEY-EXISTS-P :MAPHASH-KEYS :HASH-TABLE-KEYS :MAPHASH-VALUES :HASH-TABLE-VALUES :IF-LET :IF-NOT @@ -315,6 +316,68 @@ copy is returned by default." copy)) + (defun parse-body (body &key documentation whole) + "Parses `body` into `(values remaining-forms declarations doc-string)`. +Documentation strings are recognized only if `documentation` is true. +Syntax errors in body are signalled and `whole` is used in the signal +arguments when given." + (let ((doc nil) + (decls nil) + (current nil)) + (tagbody + :declarations + (setf current (car body)) + (when (and documentation (stringp current) (cdr body)) + (if doc + (error "Too many documentation strings in ~S." (or whole body)) + (setf doc (pop body))) + (go :declarations)) + (when (and (listp current) (eql (first current) 'declare)) + (push (pop body) decls) + (go :declarations))) + (values body (nreverse decls) doc))) + + + (defmacro defaccessor (name lambda-list &body body) + "Define the function named `name` just as with a normal `defun`. Also define the setter `(setf name)`. The form to be set (i.e., the place) should be wrapped in the local macro `accesses`. For example, + +``` + CL-USER> (let ((x 0)) + (defaccessor saved-x () + (accesses x))) + SAVED-X + (SETF SAVED-X) + CL-USER> (saved-x) + 0 + CL-USER> (setf (saved-x) 5) + 5 + CL-USER> (saved-x) + 5 +``` +" + (multiple-value-bind (remaining-forms decls doc) + (parse-body body :documentation t) + (with-gensyms (new-value) + `(progn + (defun ,name ,lambda-list + ,doc + ,@decls + (macrolet ((accesses (form) + form)) + ,@remaining-forms)) + + (defun (setf ,name) ,(cons new-value lambda-list) + ,(format nil "Setter for the function ~S." name) + ,@decls + (macrolet ((accesses (form) + `(setf ,form ,',new-value))) + ,@remaining-forms + ,new-value)) + (values + ',name + '(setf ,name)))))) + + (defun digits (n &optional (base 10)) "Return a list of the digits of the non-negative integer `n` in base `base`. By default, decimal digits are returned. @@ -626,12 +689,12 @@ See also: `symbolicate`" (defmacro looping (&body body) - "Run `body` in an environment where the symbols COLLECT!, APPEND!, SUM!, -MULTIPLY!, COUNT!, MINIMIZE!, and MAXIMIZE! are bound to functions that can be -used to collect / append, sum, multiply, count, minimize or maximize things -respectively. + "Run `body` in an environment where the symbols COLLECT!, APPEND!, ADJOIN!, +SUM!, MULTIPLY!, COUNT!, MINIMIZE!, and MAXIMIZE! are bound to functions that +can be used to collect / append, sum, multiply, count, minimize or maximize +things respectively. -Mixed usage of COLLECT!/APPEND!, SUM!, MULTIPLY!, COUNT!, MINIMIZE! and +Mixed usage of COLLECT!/APPEND!/ADJOIN!, SUM!, MULTIPLY!, COUNT!, MINIMIZE! and MAXIMIZE! is not supported. Examples: @@ -666,7 +729,7 @@ Examples: (labels ((extract-loop-type (body) (cond ((null body) nil) ((symbolp body) (find body - '(collect! append! sum! multiply! count! minimize! maximize!) + '(collect! append! adjoin! sum! multiply! count! minimize! maximize!) :test #'string=)) ((consp body) (unless (and (symbolp (car body)) (string= (car body) 'looping)) @@ -674,7 +737,7 @@ Examples: (extract-loop-type (cdr body))))))) (init-result (loop-type) (ecase loop-type - ((collect! append! minimize! maximize!) nil) + ((collect! append! adjoin! minimize! maximize!) nil) ((sum! count!) 0) ((multiply!) 1)))) (let* ((loop-type-value (extract-loop-type body)) @@ -695,17 +758,25 @@ Examples: (setf ,last (cdr ,last))))) (,(symb "COLLECT!") (item) (if (and ,loop-type (and (not (eql ,loop-type 'collect!)) - (not (eql ,loop-type 'append!)) )) + (not (eql ,loop-type 'append!)) + (not (eql ,loop-type 'adjoin!)) )) (error "Cannot use COLLECT! together with ~A" ,loop-type) (,collect-last item))) (,(symb "APPEND!") (item) (if (and ,loop-type (and (not (eql ,loop-type 'collect!)) - (not (eql ,loop-type 'append!)) )) + (not (eql ,loop-type 'append!)) + (not (eql ,loop-type 'adjoin!)) )) (error "Cannot use APPEND! together with ~A" ,loop-type) (progn (setf ,result (append ,result item) ,last (last item)) item))) + (,(symb "ADJOIN!") (item &rest adjoin-args) + (if (and ,loop-type (and (not (eql ,loop-type 'collect!)) + (not (eql ,loop-type 'append!)) + (not (eql ,loop-type 'adjoin!)))) + (error "Cannot use ADJOIN! together with ~A" ,loop-type) + (setf ,result (apply #'adjoin item ,result adjoin-args)))) (,(symb "SUM!") (item) (if (and ,loop-type (not (eql ,loop-type 'sum!))) (error "Cannot use SUM! together with ~A" ,loop-type) @@ -1075,13 +1146,14 @@ value." (eval-when (:compile-toplevel :load-toplevel :execute) (export '(keep-if keep-if-not aand aif alist-keys alist-values assoc-value - rassoc-value awhen bnd* bnd1 copy-array copy-hash-table digits divf - doalist dohash dolists dorange dorangei doseq doseqs dosublists - enumerate flatten hash-table-alist hash-table-key-exists-p - hash-table-keys hash-table-values if-let if-not iota looping - make-keyword mkstr mulf ncycle plist-keys plist-values recursively - removef repeat string-ends-with-p string-starts-with-p subdivide - subseq- symb void when-let when-let* when-not while while-not - with-gensyms with-unique-names shuffle random-elt xor))) + rassoc-value awhen bnd* bnd1 copy-array copy-hash-table defaccessor + accesses digits divf doalist dohash dolists dorange dorangei doseq + doseqs dosublists enumerate flatten hash-table-alist + hash-table-key-exists-p hash-table-keys hash-table-values if-let + if-not iota looping make-keyword mkstr mulf ncycle plist-keys + plist-values recursively removef repeat string-ends-with-p + string-starts-with-p subdivide subseq- symb void when-let when-let* + when-not while while-not with-gensyms with-unique-names shuffle + random-elt xor))) ;;;; END OF quickutils.lisp ;;;;