From fc496c42e51671ede4d5d2ddee1ad285741dee04 Mon Sep 17 00:00:00 2001
From: Thomas Voss <mail@thomasvoss.com>
Date: Wed, 18 Dec 2024 13:09:53 +0100
Subject: Move heap.lisp up

---
 2024/16/heap.lisp    | 59 ----------------------------------------------------
 2024/16/puzzles.lisp |  2 +-
 2024/heap.lisp       | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 60 insertions(+), 60 deletions(-)
 delete mode 100644 2024/16/heap.lisp
 create mode 100644 2024/heap.lisp

(limited to '2024')

diff --git a/2024/16/heap.lisp b/2024/16/heap.lisp
deleted file mode 100644
index 62d36fb..0000000
--- a/2024/16/heap.lisp
+++ /dev/null
@@ -1,59 +0,0 @@
-(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
index 91e6117..17a49f8 100644
--- a/2024/16/puzzles.lisp
+++ b/2024/16/puzzles.lisp
@@ -1,6 +1,6 @@
 #!/usr/bin/sbcl --script
 
-(load "heap.lisp")
+(load "../heap.lisp")
 
 (defstruct dnode
   (x    nil :type integer)
diff --git a/2024/heap.lisp b/2024/heap.lisp
new file mode 100644
index 0000000..62d36fb
--- /dev/null
+++ b/2024/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
-- 
cgit v1.2.3