5 ;;; Simple binary heaps, for priority queues
7 ;;; (c) 2006 Straylight/Edgeware
10 ;;;----- Licensing notice ---------------------------------------------------
12 ;;; This program is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; This program is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with this program; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
27 (:use #:common-lisp #:mdw.base)
28 (:export #:heap #:heapp
29 #:heap-key< #:heap-key
31 #:heap-count #:heap-empty-p
32 #:heap-error #:heap-underflow-error
33 #:heap-add #:heap-min #:heap-remove))
38 (:constructor make-heap
44 (key< (functionify key<-name))
45 (key (functionify key-name))
46 (store (make-array max :adjustable t)))))
47 "Structure representing a heap."
48 (key< (uninitialized-slot) :read-only t :type (function (t t) t))
49 (key #'identity :read-only t :type (function (t) t))
50 (store (uninitialized-slot) :type vector)
51 (size 0 :type unsigned-fixnum))
54 ((heap &key (key< 'key<) (key 'key) (store 'store) (size 'size))
56 "Pull aspects of the HEAP into local variables and functions so that they
57 can be messed with conveniently."
59 (with-gensyms (cmp getkey x y)
60 `(let ((,getkey (heap-key ,heap))
61 (,cmp (heap-key< ,heap))
62 (,store (heap-store ,heap))
63 (,size (heap-size ,heap)))
64 (declare (ignorable ,size)
65 (type (function (t t) t) ,cmp)
66 (type (function (t) t) ,getkey))
70 (funcall ,getkey ,x)))
71 (declare (inline ,key< ,key))
74 (declaim (inline heap-left heap-right heap-parent))
76 "Compute the left child index of the item with index I."
77 (declare (type unsigned-fixnum i))
78 (the unsigned-fixnum (+ (* 2 i) 1)))
80 "Compute the right child index of the item with index I."
81 (declare (type unsigned-fixnum i))
82 (the unsigned-fixnum (+ (* 2 i) 2)))
83 (defun heap-parent (i)
84 "Compute the parent index of the item with index I. Do not use this on
86 (declare (type unsigned-fixnum i))
87 (the unsigned-fixnum (ash (1- i) -1)))
89 (defun heap-check (heap)
90 "Verifies the heap property on the heap HEAP."
91 (declare (type heap heap))
93 (labels ((check (i key)
94 (let ((left (heap-left i))
95 (right (heap-right i)))
97 (let ((lkey (key (aref store left))))
98 (assert (not (key< lkey key)))
101 (let ((rkey (key (aref store right))))
102 (assert (not (key< rkey key)))
103 (check right rkey)))))))
105 (check 0 (key (aref store 0)))))))
107 (defun heap-count (heap)
108 "Returns a count of the number of items in the HEAP."
109 (declare (type heap heap))
112 (defun heap-empty-p (heap)
113 "Returns true if the HEAP is currently empty, or nil if it contains at
114 least one item. Note that heap-min and heap-remove are invalid operations
116 (declare (type heap heap))
117 (zerop (heap-size heap)))
119 (define-condition heap-error (error)
120 ((heap :initarg :heap :type heap :reader heap-error-heap))
122 "Parent class for error conditions affecting a heap. The accessor
123 heap-error-heap will extract the offending heap."))
125 (define-condition heap-underflow-error (heap-error)
127 (:report "Heap underflow.")
129 "Reports a heap underflow: i.e., an attempt to do something which requires
130 a nonempty heap to an empty one."))
132 (defun upheap (heap i item)
133 "Fixes up the HEAP after a (virtual) attempt to add the new ITEM at index
135 (declare (type heap heap))
137 (let ((key (key item)))
138 (loop (cond ((zerop i)
141 (let* ((parent (heap-parent i))
142 (pitem (aref store parent)))
143 (when (key< (key pitem) key)
145 (setf (aref store i) pitem
147 (setf (aref store i) item))))
149 (defun downheap (heap item)
150 "Fixes up the HEAP after a removal of the head element. The ITEM is the
151 element at the end of the heap. Does something very bad if the heap is
153 (declare (type heap heap))
157 (loop (let ((left (heap-left i))
158 (right (heap-right i)))
159 (cond ((>= left size)
164 (let* ((litem (aref store left))
167 (values left litem lkey)
168 (let* ((ritem (aref store right))
171 (values left litem lkey)
172 (values right ritem rkey)))))
173 (when (key< key ckey)
175 (setf (aref store i) citem
177 (setf (aref store i) item))))
179 (defun heap-add (heap item)
180 "Add the given ITEM to the HEAP."
181 (declare (type heap heap))
182 (let ((i (heap-size heap))
183 (store (heap-store heap)))
184 (when (>= i (array-dimension store 0))
185 (setf (heap-store heap) (adjust-array store (ash i 1))))
186 (setf (heap-size heap) (1+ i))
187 (upheap heap i item)))
189 (defun heap-min (heap)
190 "Returns the smallest item in the HEAP."
191 (declare (type heap heap))
192 (when (zerop (heap-size heap))
193 (error 'heap-underflow-error :heap heap))
194 (aref (heap-store heap) 0))
196 (defun heap-remove (heap)
197 "Removes the smallest item in the HEAP, returning something which isn't
199 (declare (type heap heap))
200 (let ((i (1- (heap-size heap)))
201 (store (heap-store heap)))
203 (error 'heap-underflow-error :heap heap))
205 (setf (heap-size heap) 0
208 (let ((item (aref store i)))
209 (setf (aref store i) nil
211 (downheap heap item))))))
214 (let ((heap (make-heap #'<))
215 (list (cons nil nil)))
217 (let ((n (random 4096)))
220 when (or (null (cdr c))
222 do (setf (cdr c) (cons n (cdr c))) (return))))
224 ;;(show (values (cdr list) heap))
226 (let ((n (heap-min heap)))
227 (assert (= n (pop (cdr list))))
231 (progn (heap-remove heap) (error "Bummer"))
232 (heap-underflow-error () nil))))))
239 (loop for i in (cdr list)
240 for j = (heap-min heap)
241 do (assert (= i j)) (heap-remove heap))
242 (assert (heap-empty-p heap)))))
244 ;;;----- That's all, folks --------------------------------------------------