diff options
Diffstat (limited to 'AoC2023/day17/solver.lisp')
-rw-r--r-- | AoC2023/day17/solver.lisp | 132 |
1 files changed, 132 insertions, 0 deletions
diff --git a/AoC2023/day17/solver.lisp b/AoC2023/day17/solver.lisp new file mode 100644 index 0000000..94598db --- /dev/null +++ b/AoC2023/day17/solver.lisp @@ -0,0 +1,132 @@ +;; 11:45 +;; +(ql:quickload '(fiveam arrows cl-heap)) + +(defun in-bounds (field crucible) + (destructuring-bind (maxrow maxcol) (array-dimensions field) + (destructuring-bind (dir row col) crucible + (declare (ignorable dir)) + (and (< -1 row maxrow) + (< -1 col maxcol))))) + +(defun advance (row col dir) + (cons dir + (ecase dir + (up (list (1- row) col)) + (lf (list row (1- col))) + (dw (list (1+ row) col)) + (rt (list row (1+ col)))))) + +(defun parse-input (filepath) + (let* ((input (uiop:read-file-lines filepath)) + (rows (length input))) + (make-array (list rows (length (car input))) + :initial-contents + (mapcar (lambda (line) + (map 'vector (lambda (c) + (logand 15 (char-code c))) + line)) + input)))) + +(defstruct (walker (:copier nil)) + (path (make-hash-table :test #'equal)) + dir row col + (track 0)) + +(defun backtrack (dir) + (ecase dir + (up 'dw) + (rt 'lf) + (dw 'up) + (lf 'rt))) + +(defun next-direction (walker adv) + (with-slots (path dir track) walker + (destructuring-bind (move nrow ncol) adv + (let ((np (alexandria:copy-hash-table path))) + (setf (gethash adv np) t) + (make-walker :path np + :dir move + :row nrow + :col ncol + :track (if (eq move dir) (1+ track) 0)))))) + +(defun next-moves (field tried walker) + (with-slots (dir row col track) walker + (arrows:->> + (remove dir '(rt dw lf up) :key #'backtrack) + (remove-if (lambda (d) (and (eq d dir) + (<= 2 track)))) + (mapcar (alexandria:curry #'advance row col)) + (remove-if-not (alexandria:curry #'in-bounds field)) + (remove-if (lambda (p) + (gethash (cons (if (eq (car p) dir) (1+ track) 0) p) tried))) + (mapcar (lambda (p) + (let ((nt (if (eq (car p) dir) (1+ track) 0))) + (setf (gethash (cons nt p) tried) t) + (next-direction walker p) + ;; (destructuring-bind (dir row col) p + ;; (make-walker :dir dir :row row :col col :track nt)) + ))) + ;; (mapcar (lambda (d) (next-direction walker d))) + ))) + +(defun finish-p (field step) + (destructuring-bind (maxrow maxcol) (array-dimensions field) + (with-slots (row col) step + (and (= row (1- maxrow)) + (= col (1- maxcol)))))) +(defun path-cost (field walker) + (let ((cost 0)) + (maphash (lambda (k v) + (declare (ignorable v)) + (destructuring-bind (dir row col) k + (declare (ignorable dir)) + (incf cost (aref field row col)))) + (walker-path walker)) + cost)) + + +(defun try (options known field iters) + (let ((next (cl-heap:dequeue options))) + ;; (with-slots (dir row col) next + ;; (format t "i: ~d cost: ~d/~d p: ~a~%" iters (path-cost field next) (hash-table-count (walker-path next)) (list dir row col))) + (when next + (if (finish-p field next) + (progn (format t "Took ~d iters\n" iters) + next) + (progn + (dolist (newm (next-moves field known next)) + (cl-heap:enqueue options + newm + (path-cost field newm))) + ;; (print (cl-heap:queue-size options)) + (try options known field (1+ iters)))))) + + + ) + +(let* ((field (parse-input "input")) + ;; (maxloss (apply #'* 9 (array-dimensions field))) + (options (make-instance 'cl-heap:priority-queue)) + (known (make-hash-table :test #'equal)) + (w (make-walker :dir 'rt :row 0 :col 0))) + ;; (setf (gethash '(rt 0 0) (walker-path w)) 1) + ;; (next-moves field w) + ;; (carry field w maxloss 0) + ;; (cl-heap:dequeue + ;; options) + (cl-heap:enqueue options w 0) + ;; (cl-heap:enqueue options '(rt 0 0 0) 0) + ;; options + ;; (print) + (time + (let ((r + (try options known field 0))) + (list (path-cost field r) r))) + ) + +;; (let ( (w (make-walker :dir 'rt :row 0 :col 0)) +;; (y (make-walker :dir 'rt :row 0 :col 0)) ) +;; (equalp w y)) +;; (make-hash-table :test #'equalp) |