From 6e88124344c72b240643e1b700904119e4584ed0 Mon Sep 17 00:00:00 2001
From: Oscar Najera <hi@oscarnajera.com>
Date: Sun, 17 Dec 2023 17:09:17 +0100
Subject: get sol day17

---
 AoC2023/day17/solver.lisp | 132 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 132 insertions(+)
 create mode 100644 AoC2023/day17/solver.lisp

(limited to 'AoC2023/day17/solver.lisp')

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)
-- 
cgit v1.2.3