day14.lisp (4817B)
1 (defpackage #:adventofcode2022/day14 2 (:use #:cl #:adventofcode2022)) 3 (in-package #:adventofcode2022/day14) 4 5 (defun make-map (inputs) 6 (loop with map = (make-hash-table :test 'equal) 7 with min-x = 500 8 with max-x = 500 9 with max-y = nil 10 for input in inputs 11 do (loop with last = (pop input) 12 for point in input 13 do (loop with axis = (if (= (car last) (car point)) #'cadr #'car) 14 with from = (funcall axis last) 15 with to = (funcall axis point) 16 with step-fun = (if (< from to) #'1+ #'1-) 17 for i = from then (funcall step-fun i) 18 for current-point = (if (eq axis #'car) 19 (list i (cadr last)) 20 (list (car last) i)) 21 when (or (null min-x) (< (car current-point) min-x)) 22 do (setf min-x (car current-point)) 23 when (or (null max-x) (> (car current-point) max-x)) 24 do (setf max-x (car current-point)) 25 when (or (null max-y) (> (cadr current-point) max-y)) 26 do (setf max-y (cadr current-point)) 27 do (setf (gethash current-point map) #\#) 28 while (not (= i to))) 29 do (setf last point)) 30 finally (return (values map (list min-x 0) (list max-x max-y))))) 31 32 (defun print-map (map min-point max-point &optional recompute-bounds?) 33 (when recompute-bounds? 34 (loop with min-x = nil 35 with max-x = nil 36 with max-y = nil 37 for point being the hash-key of map 38 when (or (null min-x) (< (car point) min-x)) 39 do (setf min-x (car point)) 40 when (or (null max-x) (> (car point) max-x)) 41 do (setf max-x (car point)) 42 when (or (null max-y) (> (cadr point) max-y)) 43 do (setf max-y (cadr point)) 44 finally (setf min-point (list min-x 0)) 45 (setf max-point (list max-x max-y)))) 46 (loop for y from (cadr min-point) to (cadr max-point) 47 do (loop for x from (car min-point) to (car max-point) 48 for cell = (gethash (list x y) map) 49 do (format t "~A" (if cell cell #\.))) 50 do (format t "~%"))) 51 52 (defun count-sand (map) 53 (loop for cell being the hash-value of map 54 when (char= cell #\o) 55 sum 1)) 56 57 (defun task1 (inputs) 58 (multiple-value-bind (map min-point max-point) 59 (make-map inputs) 60 (loop with x = 500 61 with y = 0 62 while (and (>= x (car min-point)) 63 (<= x (car max-point)) 64 (<= y (cadr max-point))) 65 for point = (list x y) 66 for down = (list x (1+ y)) 67 for down-left = (list (1- x) (1+ y)) 68 for down-right = (list (1+ x) (1+ y)) 69 if (loop for next in (list down down-left down-right) 70 when (null (gethash next map)) 71 do (setf x (car next)) 72 and do (setf y (cadr next)) 73 and do (return nil) 74 finally (return t)) 75 do (setf x 500) 76 and do (setf y 0) 77 and do (setf (gethash point map) #\o) 78 ;;and do (print-map map min-point max-point) 79 ) 80 (count-sand map))) 81 82 (defun task2 (inputs) 83 (multiple-value-bind (map min-point max-point) 84 (make-map inputs) 85 (declare (ignore min-point)) 86 (loop with x = 500 87 with y = 0 88 with floor-y = (+ (cadr max-point) 2) 89 while t 90 for point = (list x y) 91 for down = (list x (1+ y)) 92 for down-left = (list (1- x) (1+ y)) 93 for down-right = (list (1+ x) (1+ y)) 94 if (loop for next in (list down down-left down-right) 95 when (and (< (cadr next) floor-y) 96 (null (gethash next map))) 97 do (setf x (car next)) 98 and do (setf y (cadr next)) 99 and do (return nil) 100 finally (return t)) 101 do (setf x 500) 102 and do (setf y 0) 103 and do (setf (gethash point map) #\o) 104 ;; and do (print-map map min-point max-point t) 105 and when (equal (list x y) point) do (return)) 106 (count-sand map))) 107 108 (define-day 14 109 (:translate-input (lambda (line) 110 (mapcar (lambda (x) 111 (mapcar #'parse-integer 112 (uiop:split-string x :separator '(#\,)))) 113 (str:split " -> " line)))) 114 #'task1 115 #'task2)