diff options
Diffstat (limited to '2024/16')
| -rw-r--r-- | 2024/16/.gitignore | 1 | ||||
| -rw-r--r-- | 2024/16/Makefile | 1 | ||||
| -rw-r--r-- | 2024/16/heap.lisp | 59 | ||||
| -rw-r--r-- | 2024/16/puzzles.lisp | 98 |
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 |