| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; $Id$ |
| 4 | ;;; |
| 5 | ;;; Simple binary heaps, for priority queues |
| 6 | ;;; |
| 7 | ;;; (c) 2006 Straylight/Edgeware |
| 8 | ;;; |
| 9 | |
| 10 | ;;;----- Licensing notice --------------------------------------------------- |
| 11 | ;;; |
| 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. |
| 16 | ;;; |
| 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. |
| 21 | ;;; |
| 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. |
| 25 | |
| 26 | (defpackage #:heap |
| 27 | (:use #:common-lisp #:mdw.base) |
| 28 | (:export #:heap #:heapp |
| 29 | #:heap-key< #:heap-key |
| 30 | #:heap-check |
| 31 | #:heap-count #:heap-empty-p |
| 32 | #:heap-error #:heap-underflow-error |
| 33 | #:heap-add #:heap-min #:heap-remove)) |
| 34 | (in-package #:heap) |
| 35 | |
| 36 | (defstruct (heap |
| 37 | (:predicate heapp) |
| 38 | (:constructor make-heap |
| 39 | (key<-name |
| 40 | &optional |
| 41 | (key-name 'identity) |
| 42 | (max 32) |
| 43 | &aux |
| 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)) |
| 52 | |
| 53 | (defmacro with-heap |
| 54 | ((heap &key (key< 'key<) (key 'key) (store 'store) (size 'size)) |
| 55 | &body body) |
| 56 | "Pull aspects of the HEAP into local variables and functions so that they |
| 57 | can be messed with conveniently." |
| 58 | (let*/gensyms (heap) |
| 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)) |
| 67 | (flet ((,key< (,x ,y) |
| 68 | (funcall ,cmp ,x ,y)) |
| 69 | (,key (,x) |
| 70 | (funcall ,getkey ,x))) |
| 71 | (declare (inline ,key< ,key)) |
| 72 | ,@body))))) |
| 73 | |
| 74 | (declaim (inline heap-left heap-right heap-parent)) |
| 75 | (defun heap-left (i) |
| 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))) |
| 79 | (defun heap-right (i) |
| 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 |
| 85 | index zero." |
| 86 | (declare (type unsigned-fixnum i)) |
| 87 | (the unsigned-fixnum (ash (1- i) -1))) |
| 88 | |
| 89 | (defun heap-check (heap) |
| 90 | "Verifies the heap property on the heap HEAP." |
| 91 | (declare (type heap heap)) |
| 92 | (with-heap (heap) |
| 93 | (labels ((check (i key) |
| 94 | (let ((left (heap-left i)) |
| 95 | (right (heap-right i))) |
| 96 | (when (< left size) |
| 97 | (let ((lkey (key (aref store left)))) |
| 98 | (assert (not (key< lkey key))) |
| 99 | (check left lkey)) |
| 100 | (when (< right size) |
| 101 | (let ((rkey (key (aref store right)))) |
| 102 | (assert (not (key< rkey key))) |
| 103 | (check right rkey))))))) |
| 104 | (when (plusp size) |
| 105 | (check 0 (key (aref store 0))))))) |
| 106 | |
| 107 | (defun heap-count (heap) |
| 108 | "Returns a count of the number of items in the HEAP." |
| 109 | (declare (type heap heap)) |
| 110 | (heap-size heap)) |
| 111 | |
| 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 |
| 115 | on an empty heap." |
| 116 | (declare (type heap heap)) |
| 117 | (zerop (heap-size heap))) |
| 118 | |
| 119 | (define-condition heap-error (error) |
| 120 | ((heap :initarg :heap :type heap :reader heap-error-heap)) |
| 121 | (:documentation |
| 122 | "Parent class for error conditions affecting a heap. The accessor |
| 123 | heap-error-heap will extract the offending heap.")) |
| 124 | |
| 125 | (define-condition heap-underflow-error (heap-error) |
| 126 | () |
| 127 | (:report "Heap underflow.") |
| 128 | (:documentation |
| 129 | "Reports a heap underflow: i.e., an attempt to do something which requires |
| 130 | a nonempty heap to an empty one.")) |
| 131 | |
| 132 | (defun upheap (heap i item) |
| 133 | "Fixes up the HEAP after a (virtual) attempt to add the new ITEM at index |
| 134 | I." |
| 135 | (declare (type heap heap)) |
| 136 | (with-heap (heap) |
| 137 | (let ((key (key item))) |
| 138 | (loop (cond ((zerop i) |
| 139 | (return)) |
| 140 | (t |
| 141 | (let* ((parent (heap-parent i)) |
| 142 | (pitem (aref store parent))) |
| 143 | (when (key< (key pitem) key) |
| 144 | (return)) |
| 145 | (setf (aref store i) pitem |
| 146 | i parent))))) |
| 147 | (setf (aref store i) item)))) |
| 148 | |
| 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 |
| 152 | empty." |
| 153 | (declare (type heap heap)) |
| 154 | (with-heap (heap) |
| 155 | (let* ((i 0) |
| 156 | (key (key item))) |
| 157 | (loop (let ((left (heap-left i)) |
| 158 | (right (heap-right i))) |
| 159 | (cond ((>= left size) |
| 160 | (return)) |
| 161 | (t |
| 162 | (multiple-value-bind |
| 163 | (child citem ckey) |
| 164 | (let* ((litem (aref store left)) |
| 165 | (lkey (key litem))) |
| 166 | (if (>= right size) |
| 167 | (values left litem lkey) |
| 168 | (let* ((ritem (aref store right)) |
| 169 | (rkey (key ritem))) |
| 170 | (if (key< lkey rkey) |
| 171 | (values left litem lkey) |
| 172 | (values right ritem rkey))))) |
| 173 | (when (key< key ckey) |
| 174 | (return)) |
| 175 | (setf (aref store i) citem |
| 176 | i child)))))) |
| 177 | (setf (aref store i) item)))) |
| 178 | |
| 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))) |
| 188 | |
| 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)) |
| 195 | |
| 196 | (defun heap-remove (heap) |
| 197 | "Removes the smallest item in the HEAP, returning something which isn't |
| 198 | useful." |
| 199 | (declare (type heap heap)) |
| 200 | (let ((i (1- (heap-size heap))) |
| 201 | (store (heap-store heap))) |
| 202 | (cond ((minusp i) |
| 203 | (error 'heap-underflow-error :heap heap)) |
| 204 | ((zerop i) |
| 205 | (setf (heap-size heap) 0 |
| 206 | (aref store 0) nil)) |
| 207 | (t |
| 208 | (let ((item (aref store i))) |
| 209 | (setf (aref store i) nil |
| 210 | (heap-size heap) i) |
| 211 | (downheap heap item)))))) |
| 212 | |
| 213 | (defun test () |
| 214 | (let ((heap (make-heap #'<)) |
| 215 | (list (cons nil nil))) |
| 216 | (flet ((add () |
| 217 | (let ((n (random 4096))) |
| 218 | (heap-add heap n) |
| 219 | (loop for c on list |
| 220 | when (or (null (cdr c)) |
| 221 | (< n (cadr c))) |
| 222 | do (setf (cdr c) (cons n (cdr c))) (return)))) |
| 223 | (remove () |
| 224 | ;;(show (values (cdr list) heap)) |
| 225 | (cond ((cdr list) |
| 226 | (let ((n (heap-min heap))) |
| 227 | (assert (= n (pop (cdr list)))) |
| 228 | (heap-remove heap))) |
| 229 | (t |
| 230 | (handler-case |
| 231 | (progn (heap-remove heap) (error "Bummer")) |
| 232 | (heap-underflow-error () nil)))))) |
| 233 | (dotimes (i 1024) |
| 234 | (add)) |
| 235 | (dotimes (i 65536) |
| 236 | (case (random 2) |
| 237 | (0 (add)) |
| 238 | (1 (remove)))) |
| 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))))) |
| 243 | |
| 244 | ;;;----- That's all, folks -------------------------------------------------- |