5 ;;; Heap data structure; useful for priority queues and suchlike
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.
28 (:export #:make-heap #:heap-count #:heap-empty-p
29 #:heap-insert #:heap-head #:heap-remove
33 ;;;--------------------------------------------------------------------------
34 ;;; Useful indexing functions.
36 (declaim (inline parent left-child right-child))
37 (deftype index () '(and unsigned-byte fixnum))
39 (declare (type index i))
40 (the index (floor (- i 1) 2)))
42 (declare (type index i))
43 (the index (+ (* 2 i) 1)))
44 (defun right-child (i)
45 (declare (type index i))
46 (the index (+ (* 2 i) 2)))
48 ;;;--------------------------------------------------------------------------
49 ;;; Low-level heap operations.
51 (defun upheap (v key cmp n x)
52 "Insert the element X in the highest place possible in the heap."
53 (declare (type vector v)
54 (type function key cmp)
56 (let ((i n) (xk (funcall key x)))
57 (loop (when (zerop i) (return))
60 (when (funcall cmp (funcall key y) xk) (return))
65 (defun downheap (v key cmp n x)
66 "Insert the element X in the lowest place possible in the heap."
67 (declare (type vector v)
68 (type function key cmp)
70 (let ((i 0) (xk (funcall key x)))
71 (loop (let ((l (left-child i))
73 (when (>= l n) (return))
82 (if (funcall cmp yk zk)
85 (when (funcall cmp xk yk)
91 (defun check (v key cmp n)
92 "Verify the heap invariant on the heap."
93 (declare (type vector v)
94 (type function key cmp)
97 (let* ((item (aref v i))
98 (item-key (funcall key item))
102 (let ((left-item (aref v l)))
103 (assert (funcall cmp item-key (funcall key left-item))))
105 (let ((right-item (aref v r)))
106 (assert (funcall cmp item-key (funcall key right-item)))))))))
108 ;;;--------------------------------------------------------------------------
109 ;;; High-level heap things
111 (defstruct (heap (:predicate heapp) (:constructor %make-heap))
112 "Data structure for a heap."
113 (v (make-array 16) :type vector)
115 (key #'identity :type function)
116 (compare #'<= :type function))
119 (&key (compare #'<=) (key #'identity)
120 (type 't) (init-size 16) (contents nil contentsp))
123 COMPARE is a partial-order predicate: (COMPARE X Y) should return true if
124 X <= Y in some order.
126 The TYPE is the element type of the heap.
128 INIT-SIZE is the initial allocation for the heap; the heap will grow
129 automatically if necessary, so this isn't a big deal. This is only a
130 hint; make-heap may ignore it completely.
132 KEY is a function to extract the key from an element. The default is to
133 use the item unmolested.
135 CONTENTS is the initial contents of the heap. If omitted, the heap is
137 (let ((n (if contentsp (length contents) 0)))
138 (loop while (< init-size n)
139 do (setf init-size (ash init-size 1)))
140 (let ((v (make-array init-size :element-type type)))
142 (reduce (lambda (i item)
143 (upheap v key compare i item)
147 (%make-heap :compare compare :key key :n n :v v))))
149 (defun heap-count (heap)
150 "Return the number of elements in HEAP."
151 (declare (type heap heap))
154 (defun heap-empty-p (heap)
155 "True if HEAP is empty."
156 (declare (type heap heap))
157 (zerop (heap-count heap)))
159 (defun heap-insert (heap item)
160 "Insert ITEM into the HEAP."
161 (declare (type heap heap))
162 (let* ((v (heap-v heap))
164 (sz (array-dimension v 0)))
166 (setf v (adjust-array v (* 2 n))
168 (upheap v (heap-key heap) (heap-compare heap) n item)
169 (setf (heap-n heap) (1+ n))))
171 (defun heap-head (heap)
172 "Peep at the head item on HEAP."
173 (declare (type heap heap))
174 (assert (not (heap-empty-p heap)))
175 (aref (heap-v heap) 0))
177 (defun heap-remove (heap)
178 "Remove the head item from HEAP and return it."
179 (declare (type heap heap))
180 (assert (not (heap-empty-p heap)))
181 (let ((v (heap-v heap))
182 (n (1- (heap-n heap))))
184 (setf (heap-n heap) n)
185 (downheap v (heap-key heap) (heap-compare heap) n (aref v n)))))
187 (defun heap-sort (items compare &key (key #'identity))
188 "Return the ITEMS, least-first, as sorted by the ordering COMPARE."
189 (let ((heap (make-heap :compare compare :contents items :key key)))
190 (loop repeat (heap-n heap)
191 collect (heap-remove heap))))
193 ;;;----- That's all, folks --------------------------------------------------