heap: Binary heap for priority queues.

[lisp] / heap.lisp

;;; -*-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 --------------------------------------------------