From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 3 Jul 2007 10:46:30 +0000 (+0100)
Subject: heap: Binary heap for priority queues.
X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/refs/heads/other-heap

heap: Binary heap for priority queues.
---

diff --git a/heap.lisp b/heap.lisp
new file mode 100644
index 0000000..abb5a2c
--- /dev/null
+++ b/heap.lisp
@@ -0,0 +1,244 @@
+;;; -*-lisp-*-
+;;;
+;;; $Id$
+;;;
+;;; Simple binary heaps, for priority queues
+;;;
+;;; (c) 2006 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;; 
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;; 
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:heap
+  (:use #:common-lisp #:mdw.base)
+  (:export #:heap #:heapp
+	   #:heap-key< #:heap-key
+	   #:heap-check
+	   #:heap-count #:heap-empty-p
+	   #:heap-error #:heap-underflow-error
+	   #:heap-add #:heap-min #:heap-remove))
+(in-package #:heap)
+
+(defstruct (heap
+	     (:predicate heapp)
+	     (:constructor make-heap
+			   (key<-name
+			    &optional
+			    (key-name 'identity)
+			    (max 32)
+			    &aux
+			    (key< (functionify key<-name))
+			    (key (functionify key-name))
+			    (store (make-array max :adjustable t)))))
+  "Structure representing a heap."
+  (key< (uninitialized-slot) :read-only t :type (function (t t) t))
+  (key #'identity :read-only t :type (function (t) t))
+  (store (uninitialized-slot) :type vector)
+  (size 0 :type unsigned-fixnum))
+
+(defmacro with-heap
+    ((heap &key (key< 'key<) (key 'key) (store 'store) (size 'size))
+     &body body)
+  "Pull aspects of the HEAP into local variables and functions so that they
+   can be messed with conveniently."
+  (let*/gensyms (heap)
+    (with-gensyms (cmp getkey x y)
+      `(let ((,getkey (heap-key ,heap))
+	     (,cmp (heap-key< ,heap))
+	     (,store (heap-store ,heap))
+	     (,size (heap-size ,heap)))
+	(declare (ignorable ,size)
+	         (type (function (t t) t) ,cmp)
+	         (type (function (t) t) ,getkey))
+	(flet ((,key< (,x ,y)
+		 (funcall ,cmp ,x ,y))
+	       (,key (,x)
+		 (funcall ,getkey ,x)))
+	  (declare (inline ,key< ,key))
+	  ,@body)))))
+
+(declaim (inline heap-left heap-right heap-parent))
+(defun heap-left (i)
+  "Compute the left child index of the item with index I."
+  (declare (type unsigned-fixnum i))
+  (the unsigned-fixnum (+ (* 2 i) 1)))
+(defun heap-right (i)
+  "Compute the right child index of the item with index I."
+  (declare (type unsigned-fixnum i))
+  (the unsigned-fixnum (+ (* 2 i) 2)))
+(defun heap-parent (i)
+  "Compute the parent index of the item with index I.  Do not use this on
+   index zero."
+  (declare (type unsigned-fixnum i))
+  (the unsigned-fixnum (ash (1- i) -1)))
+
+(defun heap-check (heap)
+  "Verifies the heap property on the heap HEAP."
+  (declare (type heap heap))
+  (with-heap (heap)
+    (labels ((check (i key)
+	       (let ((left (heap-left i))
+		     (right (heap-right i)))
+		 (when (< left size)
+		   (let ((lkey (key (aref store left))))
+		     (assert (not (key< lkey key)))
+		     (check left lkey))
+		   (when (< right size)
+		     (let ((rkey (key (aref store right))))
+		       (assert (not (key< rkey key)))
+		       (check right rkey)))))))
+      (when (plusp size)
+	(check 0 (key (aref store 0)))))))
+
+(defun heap-count (heap)
+  "Returns a count of the number of items in the HEAP."
+  (declare (type heap heap))
+  (heap-size heap))
+
+(defun heap-empty-p (heap)
+  "Returns true if the HEAP is currently empty, or nil if it contains at
+   least one item.  Note that heap-min and heap-remove are invalid operations
+   on an empty heap."
+  (declare (type heap heap))
+  (zerop (heap-size heap)))
+
+(define-condition heap-error (error)
+  ((heap :initarg :heap :type heap :reader heap-error-heap))
+  (:documentation
+   "Parent class for error conditions affecting a heap.  The accessor
+    heap-error-heap will extract the offending heap."))
+
+(define-condition heap-underflow-error (heap-error)
+  ()
+  (:report "Heap underflow.")
+  (:documentation
+   "Reports a heap underflow: i.e., an attempt to do something which requires
+    a nonempty heap to an empty one."))
+
+(defun upheap (heap i item)
+  "Fixes up the HEAP after a (virtual) attempt to add the new ITEM at index
+   I."
+  (declare (type heap heap))
+  (with-heap (heap)
+    (let ((key (key item)))
+      (loop (cond ((zerop i)
+		   (return))
+		  (t
+		   (let* ((parent (heap-parent i))
+			  (pitem (aref store parent)))
+		     (when (key< (key pitem) key)
+		       (return))
+		     (setf (aref store i) pitem
+			   i parent)))))
+      (setf (aref store i) item))))
+
+(defun downheap (heap item)
+  "Fixes up the HEAP after a removal of the head element.  The ITEM is the
+   element at the end of the heap.  Does something very bad if the heap is
+   empty." 
+  (declare (type heap heap))
+  (with-heap (heap)
+    (let* ((i 0)
+	   (key (key item)))
+      (loop (let ((left (heap-left i))
+		  (right (heap-right i)))
+	      (cond ((>= left size)
+		     (return))
+		    (t
+		     (multiple-value-bind
+			 (child citem ckey)
+			 (let* ((litem (aref store left))
+				(lkey (key litem)))
+			   (if (>= right size)
+			       (values left litem lkey)
+			       (let* ((ritem (aref store right))
+				      (rkey (key ritem)))
+			       (if (key< lkey rkey)
+				   (values left litem lkey)
+				   (values right ritem rkey)))))
+		       (when (key< key ckey)
+			 (return))
+		       (setf (aref store i) citem
+			     i child))))))
+      (setf (aref store i) item))))
+
+(defun heap-add (heap item)
+  "Add the given ITEM to the HEAP."
+  (declare (type heap heap))
+  (let ((i (heap-size heap))
+	(store (heap-store heap)))
+    (when (>= i (array-dimension store 0))
+      (setf (heap-store heap) (adjust-array store (ash i 1))))
+    (setf (heap-size heap) (1+ i))
+    (upheap heap i item)))
+
+(defun heap-min (heap)
+  "Returns the smallest item in the HEAP."
+  (declare (type heap heap))
+  (when (zerop (heap-size heap))
+    (error 'heap-underflow-error :heap heap))
+  (aref (heap-store heap) 0))
+
+(defun heap-remove (heap)
+  "Removes the smallest item in the HEAP, returning something which isn't
+   useful." 
+  (declare (type heap heap))
+  (let ((i (1- (heap-size heap)))
+	(store (heap-store heap)))
+    (cond ((minusp i)
+	   (error 'heap-underflow-error :heap heap))
+	  ((zerop i)
+	   (setf (heap-size heap) 0
+		 (aref store 0) nil))
+	  (t
+	   (let ((item (aref store i)))
+	     (setf (aref store i) nil
+		   (heap-size heap) i)
+	     (downheap heap item))))))
+
+(defun test ()
+  (let ((heap (make-heap #'<))
+	(list (cons nil nil)))
+    (flet ((add ()
+	     (let ((n (random 4096)))
+	       (heap-add heap n)
+	       (loop for c on list
+		     when (or (null (cdr c))
+			      (< n (cadr c)))
+		     do (setf (cdr c) (cons n (cdr c))) (return))))
+	   (remove ()
+	     ;;(show (values (cdr list) heap))
+	     (cond ((cdr list)
+		    (let ((n (heap-min heap)))
+		      (assert (= n (pop (cdr list))))
+		      (heap-remove heap)))
+		   (t
+		    (handler-case
+			(progn (heap-remove heap) (error "Bummer"))
+		      (heap-underflow-error () nil))))))
+      (dotimes (i 1024)
+	(add))
+      (dotimes (i 65536)
+	(case (random 2)
+	  (0 (add))
+	  (1 (remove))))
+      (loop for i in (cdr list)
+	    for j = (heap-min heap)
+	    do (assert (= i j)) (heap-remove heap))
+      (assert (heap-empty-p heap)))))
+
+;;;----- That's all, folks --------------------------------------------------