/[cl-heap]/cl-heap/tags/release-0.1.5/fibonacci-heap.lisp
ViewVC logotype

Contents of /cl-heap/tags/release-0.1.5/fibonacci-heap.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 16 - (show annotations)
Wed Apr 4 04:43:50 2012 UTC (2 years ago) by rneeser
File size: 12854 byte(s)
Tagged the 0.1.5 release
1 ;;; Copyright 2009-2010 Rudolph Neeser <rudy.neeser@gmail.com>.
2 ;;; Copyright 2012 CL-HEAP (See AUTHORS file).
3 ;;;
4 ;;; This file is part of CL-HEAP
5 ;;;
6 ;;; CL-HEAP is free software: you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation, either version 3 of the License, or
9 ;;; (at your option) any later version.
10 ;;;
11 ;;; CL-HEAP is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with CL-HEAP. If not, see <http://www.gnu.org/licenses/>.
18
19 ;;;----------------------------------------------------------------
20
21 (in-package #:cl-heap)
22
23 ;;;----------------------------------------------------------------
24
25 (defclass fibonacci-heap (heap)
26 ((root :initform nil
27 :documentation "The minimum element in the tree.")
28 (count :initform 0
29 :documentation "The number of items in the heap."))
30 (:documentation "A heap made up of item-disjoint, heap-ordered
31 trees. Has some good time constraints on various heap operations."))
32
33 ;;;----------------------------------------------------------------
34
35 (defclass node ()
36 ((item :initform nil
37 :initarg :item
38 :accessor node-item)
39 (parent :initform nil
40 :accessor node-parent)
41 (child :initform nil
42 :accessor node-child)
43 (rank :initform 0
44 :accessor node-rank
45 :documentation "The number of children the node has.")
46 (marked :initform nil
47 :accessor node-marked-p
48 :documentation "Used to implement cascading cuts.")
49 (next :initform nil
50 :accessor node-next)
51 (last :initform nil
52 :accessor node-last))
53 (:documentation "A class used for storing data in a FIBONACCI-HEAP."))
54
55 (defmethod initialize-instance :after ((node node) &key)
56 (with-slots (next last) node
57 (setf next node
58 last node)))
59
60 (defmethod print-object ((node node) stream)
61 (print-unreadable-object (node stream :type t :identity t)
62 (format stream "Item: ~a" (slot-value node 'item))))
63
64 ;;;----------------------------------------------------------------
65 ;;; Unexported functions for handling nodes.
66
67 (defgeneric unmark-node (node)
68 (:method ((node node))
69 (setf (node-marked-p node) nil)))
70
71 (defgeneric mark-node (node)
72 (:method ((node node))
73 (setf (node-marked-p node) t)))
74
75 (defgeneric is-node-root-p (node)
76 (:method ((node node))
77 (null (node-parent node))))
78
79 (defgeneric concatenate-node-lists (lhs rhs)
80 (:method ((lhs node) (rhs null))
81 lhs)
82 (:method ((lhs null) (rhs node))
83 rhs)
84 (:method ((lhs node) (rhs node))
85 (psetf (node-next lhs) rhs
86 (node-last (node-next lhs)) (node-last rhs)
87 (node-last rhs) lhs
88 (node-next (node-last rhs)) (node-next lhs))
89 lhs))
90
91
92 (defgeneric delete-node (node)
93 (:documentation "Deletes this node from the linked list that it
94 represents, and returns the new list. Nulls the node's parent, and
95 resets its rank if appropriate.")
96 (:method ((node null))
97 nil)
98 (:method ((node node))
99 (with-slots (next last parent) node
100 (let ((result (when (not (eq next node))
101 next)))
102 (when result ; There was something to delete.
103 (psetf (node-last next) last
104 (node-next last) next
105 next node
106 last node))
107 (when parent ; Remove the item from any parents.
108 (decf (node-rank parent))
109 (when (eq (node-child parent) node)
110 (setf (node-child parent) result))
111 (setf parent nil))
112 result))))
113
114
115
116 (defmacro do-each-node ((symbol node) &body body)
117 (let ((node node)
118 (last (gensym))
119 (next (gensym)))
120 `(when ,node
121 (loop
122 with ,last = (node-last ,node)
123 for ,symbol = ,node then ,next
124 for ,next = (node-next ,node) then (node-next ,next)
125 while (not (eq ,symbol ,last))
126 do (progn
127 ,@body)
128 finally (progn
129 ,@body)))))
130
131
132 ;;;--------------------
133 ;;; Unexported functions
134
135 (defgeneric meld (one two)
136 (:documentation "Joins together two fibonacci heaps."))
137
138 ;; This should not increase the heap's count of its items, since it's
139 ;; used in areas such as linking, where this must not occur.
140 (defmethod meld ((heap fibonacci-heap) (item node))
141 "Adds a node to the heap."
142 (with-slots (root) heap
143 (cond
144 ((null root)
145 (setf root item))
146 ((compare-items heap (node-item root) (node-item item))
147 (setf root (concatenate-node-lists root item)))
148 (t
149 (setf root (concatenate-node-lists item root)))))
150 heap)
151
152 ;; This should adjust the heap's count of its children, since it's use
153 ;; only makes sense in places where more items are added.
154 (defmethod meld ((heap1 fibonacci-heap) (heap2 fibonacci-heap))
155 (with-slots ((heap1-root root)
156 (heap1-count count)) heap1
157 (with-slots ((heap2-root root)
158 (heap2-count count)) heap2
159 (setf heap1-root (concatenate-node-lists heap1-root heap2-root))
160 (unless (compare-items heap1 (node-item heap1-root) (node-item heap2-root))
161 (setf heap1-root heap2-root
162 heap1-count (+ heap1-count heap2-count))))))
163
164 (defgeneric link (heap node-one node-two)
165 (:documentation "Places node-two as a child of node-one if
166 node-one's item is smaller, or vice versa.")
167 (:method ((heap fibonacci-heap) (node-one node) (node-two node))
168 (with-slots ((one-child child)
169 (one-item item)
170 (one-rank rank)) node-one
171 (with-slots ((two-child child)
172 (two-item item)
173 (two-rank rank)) node-two
174 (cond
175 ((compare-items heap one-item two-item)
176 (delete-node node-two)
177 (unless (is-node-root-p node-two)
178 (unmark-node node-two))
179 (setf one-child (concatenate-node-lists one-child node-two)
180 (node-parent node-two) node-one)
181 (incf one-rank)
182 node-one)
183 (t
184 (delete-node node-one)
185 (setf two-child (concatenate-node-lists two-child node-one)
186 (node-parent node-one) node-two)
187 (incf two-rank)
188 node-two))))))
189
190 (defgeneric cut-node (heap node)
191 (:documentation "Cuts a child from its parent and makes and places
192 it in the root list.")
193 (:method ((heap fibonacci-heap) (node node))
194 (let ((parent (node-parent node)))
195 (with-slots (root) heap
196 (delete-node node)
197 (concatenate-node-lists root node)
198 (cond
199 ((and parent (not (is-node-root-p parent)) (node-marked-p parent))
200 (cut-node heap parent))
201 ((and parent (not (is-node-root-p parent)))
202 (mark-node parent)
203 heap))))))
204
205
206 ;;;----------------------------------------------------------------
207 ;;; Exported Functions
208
209 (defmethod empty-heap ((heap fibonacci-heap))
210 "Clears all items from the heap. This is a constant time operation."
211 (with-slots (root count) heap
212 (setf root nil
213 count 0))
214 heap)
215
216 (defmethod is-empty-heap-p ((heap fibonacci-heap))
217 (unless (slot-value heap 'root)
218 t))
219
220 (defmethod heap-size ((heap fibonacci-heap))
221 (slot-value heap 'count))
222
223 (defmethod add-to-heap ((heap fibonacci-heap) item)
224 "Adds an item to a Fibonacci-heap. This is a constant time
225 operation. Returns the item added to the heap."
226 (let ((node (make-instance 'node :item item)))
227 (meld heap node)
228 (incf (slot-value heap 'count))
229 (values item node)))
230
231 (defmethod add-all-to-heap ((heap fibonacci-heap) (items list))
232 "Adds the following list of items into the heap. This is an O(n) operation."
233 (with-slots (count) heap
234 (loop for i in items
235 do (progn
236 (meld heap (make-instance 'node :item i))
237 (incf count))))
238 heap)
239
240 (defmethod peep-at-heap ((heap fibonacci-heap))
241 "See the heap's minimum value without modifying the heap. This is a
242 constant time operation."
243 (with-slots (root) heap
244 (when root
245 (node-item root))))
246
247 (defmethod pop-heap ((heap fibonacci-heap))
248 "Remove the minimum element in the tree. This has an amortised
249 running time of O(log(n)), where n is the number of items in the
250 heap."
251 (unless (is-empty-heap-p heap)
252 (let ((item (peep-at-heap heap)))
253 (with-slots (root count) heap
254 ;; Delete the minimum.
255 (concatenate-node-lists root (node-child root))
256 (setf root (delete-node root))
257 (when root
258 (let ((ranks (make-array (1+ (ceiling (log count 2))) :initial-element nil))
259 (min nil))
260 ;; Merge all trees of the same rank.
261 (labels ((sort-node (node)
262 (let ((position (node-rank node)))
263 (cond
264 ((aref ranks position)
265 (let ((new (link heap node (aref ranks position))))
266 (setf (aref ranks position) nil)
267 (sort-node new)))
268 (t
269 (setf (aref ranks position) node))))))
270 (do-each-node (node root)
271 ;; The newly added nodes should not have a parent
272 (setf (node-parent node) nil)
273 (delete-node node)
274 (sort-node node)))
275 (loop for tree across ranks
276 do (when (not (null tree))
277 (cond
278 ((null min)
279 (setf min tree))
280 ((compare-items heap
281 (node-item min)
282 (node-item tree))
283
284 (setf min (concatenate-node-lists min tree)))
285 (t
286 (setf min (concatenate-node-lists tree min))))))
287 (setf root min)))
288 (decf (slot-value heap 'count))
289 item))))
290
291
292 (defmethod nmerge-heaps ((first fibonacci-heap) (second fibonacci-heap))
293 "Destructively marges the two heaps. This is a constant time
294 operation."
295 (with-slots ((first-root root)
296 (first-key key)
297 (first-fun sort-fun)) first
298 (with-slots ((second-root root)
299 (second-key key)
300 (second-fun sort-fun)) second
301 (unless (and (eq first-key second-key)
302 (eq first-fun second-fun))
303 (error 'heap-error :message "These two heaps were constructed using different
304 access keys and sorting functions."))))
305 (meld first second)
306 first)
307
308 (defmethod merge-heaps ((first fibonacci-heap) (second fibonacci-heap))
309 "Returns the merge of the two given heaps. This operation runs in
310 O(n + m), where n and m are the number of items in each heap."
311 (with-slots ((first-root root)
312 (first-key key)
313 (first-fun sort-fun)) first
314 (with-slots ((second-root root)
315 (second-key key)
316 (second-fun sort-fun)) second
317 (unless (and (eq first-key second-key)
318 (eq first-fun second-fun))
319 (error 'heap-error :message "These two heaps were constructed using different
320 access keys and sorting functions."))
321 (let ((result (make-instance 'fibonacci-heap
322 :sort-fun first-fun
323 :key first-key)))
324 (labels ((add-from-level (node-list)
325 (when node-list
326 (do-each-node (node node-list)
327 (add-from-level (node-child node))
328 (add-to-heap result (node-item node))))))
329 (add-from-level first-root)
330 (add-from-level second-root))
331 result))))
332
333 ;;; This method decreases the node's key, removes the node from the
334 ;;; tree and adds it to the root list (unless this is of course where
335 ;;; the node originally was.
336 (defmethod decrease-key ((heap fibonacci-heap) (item-index node) value)
337 "Changes the value of an item represented by the ITEM-INDEX to
338 VALUE. This index is returned as the second argument to
339 ADD-TO-HEAP. This is an amortised constant time operation."
340 (with-slots (key sort-fun) heap
341 (unless (funcall sort-fun value (funcall key (node-item item-index)))
342 (error 'key-error :message
343 (format nil "The given value (~a) must be less than the current value (~a)."
344 value (funcall key (node-item item-index)))))
345 (if (eq key #'identity)
346 (setf (node-item item-index) value)
347 (handler-case
348 (funcall key (node-item item-index) value)
349 (error (e)
350 (declare (ignore e))
351 (error 'key-error))))
352 (cond
353 ;; A child of something. See if cascading cuts should occur.
354 ((node-parent item-index)
355 (let ((parent (node-parent item-index)))
356 (delete-node item-index)
357 (meld heap item-index)
358 (when (not (is-node-root-p parent))
359 (if (node-marked-p parent)
360 (cut-node heap parent)
361 (mark-node parent)))))
362 (t ; In the list with the root.
363 (with-slots (root) heap
364 (unless (compare-items heap (node-item root) (node-item item-index))
365 (setf root item-index))))))
366 heap)
367
368 (defmethod delete-from-heap ((heap fibonacci-heap) (item-index node))
369 "Removes an item from the heap, as pointed to by item-index. This
370 operation is amortised O(1), unless the item removed is the minimum item, in
371 which case the operation is equivalent to a POP-HEAP."
372 (with-slots (root count) heap
373 (let ((parent (node-parent item-index)))
374 (cond
375 ((eq root item-index)
376 (pop-heap heap))
377 (t
378 (do-each-node (child (node-child item-index))
379 (setf (node-parent child) nil))
380 ;; Add children to root level.
381 (concatenate-node-lists root (node-child item-index))
382 (delete-node item-index)
383 (decf count)))
384 (when (and parent (not (is-node-root-p parent)))
385 (if (node-marked-p parent)
386 (cut-node heap parent)
387 (mark-node parent)))))
388 heap)

  ViewVC Help
Powered by ViewVC 1.1.5