aboutsummaryrefslogtreecommitdiffstats
path: root/AoC2023/day17/solver.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'AoC2023/day17/solver.lisp')
-rw-r--r--AoC2023/day17/solver.lisp132
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)