Skip to content

Commit

Permalink
Refactor 2023/22
Browse files Browse the repository at this point in the history 
- 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
  • Loading branch information
@iamFIREcracker
iamFIREcracker committed Feb 1, 2024
1 parent 925d9c6 commit 198ba09
Show file tree
Hide file tree
Showing 3 changed files with 171 additions and 97 deletions.
149 changes: 75 additions & 74 deletions src/2023/day22.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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))
1 change: 1 addition & 0 deletions vendor/make-quickutils.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@
:bnd1
:copy-array
:copy-hash-table
:defaccessor
:digits
:divf
:doalist
Expand Down
118 changes: 95 additions & 23 deletions vendor/quickutils.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand All @@ -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
Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -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:
Expand Down Expand Up @@ -666,15 +729,15 @@ 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))
(or (extract-loop-type (car body))
(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))
Expand All @@ -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)
Expand Down Expand Up @@ -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 ;;;;

0 comments on commit 198ba09

Please sign in to comment.