Add 2024 day 16 solutions

4 files changed, 159 insertions, 0 deletions

diff --git a/2024/16/.gitignore b/2024/16/.gitignore
new file mode 100644
index 0000000..5fcaefb
--- /dev/null
+++ b/2024/16/.gitignore
@@ -0,0 +1 @@
+puzzle-[12].lisp
\ No newline at end of file
diff --git a/2024/16/Makefile b/2024/16/Makefile
new file mode 100644
index 0000000..5a21270
--- /dev/null
+++ b/2024/16/Makefile
@@ -0,0 +1 @@
+include ../../Makefiles/lisp.mk
\ No newline at end of file
diff --git a/2024/16/heap.lisp b/2024/16/heap.lisp
new file mode 100644
index 0000000..62d36fb
--- /dev/null
+++ b/2024/16/heap.lisp
@@ -0,0 +1,59 @@
+(defpackage #:heap
+  (:use :cl)
+  (:export :dequeue :emptyp :enqueue :make-heap))
+
+(in-package #:heap)
+
+(defun make-heap (&key (priority-function #'identity))
+  (cons (make-array 0 :fill-pointer t) priority-function))
+
+(defun enqueue (item heap)
+  (let ((heap-vec (car heap)))
+    (vector-push-extend item heap-vec)
+    (%sift-down heap 0 (1- (length heap-vec)))))
+
+(defun dequeue (heap)
+  (let* ((heap-vec (car heap))
+         (last-item (vector-pop heap-vec)))
+    (if (zerop (length heap-vec))
+        last-item
+        (prog1
+            (aref heap-vec 0)
+          (setf (aref heap-vec 0) last-item)
+          (%sift-up heap 0)))))
+
+(defun emptyp (heap)
+  (zerop (length (car heap))))
+
+(defun %sift-down (heap start-pos pos)
+  (let* ((heap-vec (car heap))
+         (heap-fn (cdr heap))
+         (new-item (aref heap-vec pos)))
+    (loop while (> pos start-pos) do
+      (let* ((parent-pos (ash (1- pos) -1))
+             (parent (aref heap-vec parent-pos)))
+        (unless (< (funcall heap-fn new-item)
+                   (funcall heap-fn parent))
+          (loop-finish))
+        (setf (aref heap-vec pos) parent)
+        (setq pos parent-pos)))
+    (setf (aref heap-vec pos) new-item)))
+
+(defun %sift-up (heap pos)
+  (let* ((heap-vec (car heap))
+         (heap-fn (cdr heap))
+         (end-pos (length heap-vec))
+         (start-pos pos)
+         (new-item (aref heap-vec pos))
+         (child-pos (1+ (* 2 pos))))
+    (loop while (< child-pos end-pos) do
+      (let ((right-pos (1+ child-pos)))
+        (when (and (< right-pos end-pos)
+                   (>= (funcall heap-fn (aref heap-vec child-pos))
+                       (funcall heap-fn (aref heap-vec right-pos))))
+          (setq child-pos right-pos))
+        (setf (aref heap-vec pos) (aref heap-vec child-pos))
+        (setq pos child-pos
+              child-pos (1+ (* 2 pos)))))
+    (setf (aref heap-vec pos) new-item)
+    (%sift-down heap start-pos pos)))
\ No newline at end of file
diff --git a/2024/16/puzzles.lisp b/2024/16/puzzles.lisp
new file mode 100644
index 0000000..91e6117
--- /dev/null
+++ b/2024/16/puzzles.lisp
@@ -0,0 +1,98 @@
+#!/usr/bin/sbcl --script
+
+(load "heap.lisp")
+
+(defstruct dnode
+  (x    nil :type integer)
+  (y    nil :type integer)
+  (dir  nil :type integer)
+  (seen nil :type list))
+
+(defun main (filename)
+  (multiple-value-call #'dijkstra (parse-maze filename)))
+
+(defun dijkstra (maze beg end)
+  (let* ((directions #2A((0 -1) (+1 0) (0 +1) (-1 0)))
+         (cost-table (make-hash-table :test #'dnode=))
+         (to-visit (heap:make-heap :priority-function #'cdr))
+         (lowest-score most-positive-fixnum)
+         seen-tiles)
+    (flet ((get-cost (node) (or (gethash node cost-table)
+                                most-positive-fixnum)))
+      (heap:enqueue (cons (make-dnode :x (car beg) :y (cdr beg)
+                                      :dir 1 :seen (list beg))
+                          0)
+                    to-visit)
+      (loop
+        (let* ((pair (heap:dequeue to-visit))
+               (node (car pair))
+               (cost (cdr pair))
+               (dir  (dnode-dir node))
+               (seen (dnode-seen node)))
+          (when (> cost lowest-score)
+            ;; START PART 1
+            (return-from dijkstra cost)
+            ;; END PART 1 START PART 2
+            (return-from dijkstra (length seen-tiles))
+            ;; END PART 2
+            )
+          (unless (< (get-cost node) cost)
+            (setf (gethash node cost-table) cost)
+            (dolist (d (list dir (mod (1- dir) 4) (mod (1+ dir) 4)))
+              (let* ((x (+ (dnode-x node) (aref directions d 0)))
+                     (y (+ (dnode-y node) (aref directions d 1)))
+                     (nseen (adjoin (cons x y) seen :test #'equal))
+                     (nnode (make-dnode :x x :y y :dir d :seen nseen))
+                     (ncost (+ cost (if (= d dir) 1 1001))))
+                (when (and (<= ncost (get-cost nnode))
+                           (dnode-pos-valid-p nnode maze))
+                  (if (equal (cons x y) end)
+                      (setq lowest-score ncost
+                            seen-tiles (union seen-tiles nseen :test #'equal))
+                      (progn
+                        (setf (gethash nnode cost-table) ncost)
+                        (heap:enqueue (cons nnode ncost) to-visit))))))))))))
+
+(defun dnode= (x y)
+  (and (= (dnode-x x) (dnode-x y))
+       (= (dnode-y x) (dnode-y y))
+       (= (dnode-dir x) (dnode-dir y))))
+
+(defun sxhash-dnode (node)
+  (sxhash (list (dnode-x node)
+                (dnode-y node)
+                (dnode-dir node))))
+
+(define-hash-table-test dnode= sxhash-dnode)
+
+(defun dnode-pos-valid-p (node maze)
+  (destructuring-bind (my mx) (array-dimensions maze)
+    (let ((nx (dnode-x node))
+          (ny (dnode-y node)))
+      (and (< -1 nx mx)
+           (< -1 ny my)
+           (char/= #\# (aref maze ny nx))))))
+
+(defun parse-maze (filename)
+  (with-open-file (stream filename)
+    (multiple-value-bind (lines line-count beg end)
+        (loop with beg = 0
+              with end = 0
+              for line = (read-line stream nil)
+              for line-count upfrom 0
+              while line
+              for s-pos = (position #\S line)
+              for e-pos = (position #\E line)
+              if s-pos
+                do (setq beg (cons s-pos line-count))
+              if e-pos
+                do (setq end (cons e-pos line-count))
+              collect line into lines
+              finally (return (values lines line-count beg end)))
+      (values
+       (make-array (list line-count (length (first lines)))
+                   :element-type 'character
+                   :initial-contents lines)
+       beg end))))
+
+(format t "~d~%" (main "input"))
\ No newline at end of file