Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 224 lines (199 sloc) 7.143 kB
a635768 added rank pairing heap
Stephan Frank authored
1 (defpackage :rank-pairing-heap (:use :CL)
2 (:export
3 #:rank-pairing-heap
4 #:clear-heap
5 #:empty-p
6 #:insert
7 #:peek-min
8 #:extract-min
9 #:extract-node
10 #:heap-size
11 #:decrease-key
12 #:meld
13 ))
14
15 (in-package :rank-pairing-heap)
16
17 ;;;; Rank-Pairing min-heap, see "Bernhard Haeupler, Siddartha Sen,
18 ;;;; Robert E. Tarjan: Rank-Pairing Heaps, ESA 2009, Lecture Notes in
19 ;;;; Computer Science, 2009, Volume 5757/2009, 659--670."
20
21 ;;; This is the one tree variant where the root is not a cyclic list,
22 ;;; but a single node.
23
24 (defstruct (node (:constructor %make-node (key data)))
25 (key 0 :type fixnum)
26 (data nil)
27 (lchild nil :type (or null node))
28 (rchild nil :type (or null node))
29 (parent nil :type (or null node))
30 (rank 0 :type (integer 0 #.(floor (log most-positive-fixnum
31 (/ (1+ (sqrt 5)) 2))))))
32
33 (defclass rank-pairing-heap ()
34 ((size :initform 0 :initarg :size
35 :type (integer 0 *))
36 (root :initform nil :initarg :roots
37 :type (or null node))))
38
39 (defmethod print-object ((obj rank-pairing-heap) stream)
40 (print-unreadable-object (obj stream :type t :identity t)
41 (format stream "~4I~:_size: ~A~:_" (slot-value obj 'size))))
42
43 (defun heap-size (heap)
44 (slot-value heap 'size))
45
46 (defun empty-p (heap)
47 (zerop (slot-value heap 'size)))
48
49 (defun clear-heap (heap)
50 (setf (slot-value heap 'size) 0
51 (slot-value heap 'root) nil)
52 heap)
53
54 (defun peek-min (heap)
55 (let ((node (slot-value heap 'root)))
56 (when node
57 (values (node-data node)
58 (node-key node)))))
59
60
61 (defun extract-min (heap)
62 (declare (type rank-pairing-heap heap))
bfba26a LET* => LET
Stephan Frank authored
63 (let ((root (slot-value heap 'root))
64 (buckets (make-array (ceiling (log most-positive-fixnum (/ (1+ (sqrt 5)) 2)))
65 ;; approx of max. required buckets
66 :element-type '(or null node)
67 :initial-element nil)))
a635768 added rank pairing heap
Stephan Frank authored
68 (declare (dynamic-extent buckets))
69 (if (zerop (decf (slot-value heap 'size)))
70 (setf (slot-value heap 'root) nil)
a912d6c @sfrank retry
authored
71 (let (tree)
a635768 added rank pairing heap
Stephan Frank authored
72 (loop for i = (node-lchild root) then next
73 for next = (shiftf (node-rchild i) nil)
74 with result = nil
75 do (let ((rank (node-rank i)))
76 (setf (node-parent i) nil)
77 (if (aref buckets rank)
78 (progn
79 (push (link-fair (aref buckets rank) i)
80 result)
81 (setf (aref buckets rank) nil))
82 (setf (aref buckets rank) i)))
83 while next
84 finally
85 (loop for n in result
86 do (setf tree (link tree n)))
87 (loop for v across buckets
88 when v
89 do (setf tree (link v tree))
90 finally
91 (setf (slot-value heap 'root) tree)))))
92 (values (node-data root)
93 (node-key root))))
94
95 (defun insert (heap key data)
96 (let ((node (%make-node key data)))
97 (if (= (incf (slot-value heap 'size)) 1)
98 (setf (slot-value heap 'root) node)
99 (setf (slot-value heap 'root)
100 (link (slot-value heap 'root) node)))
101 node))
102
103 (defun decrease-key (heap node key)
104 (if (< (node-key node) key)
105 (error "Cannot decrease key: new key greater than current key.")
106 (progn (setf (node-key node) key)
107 (setf (node-rank node)
108 (1+ (d-rank (node-lchild node))))))
109 (unless (eq node (slot-value heap 'root))
110 (setf (slot-value heap 'root)
111 (link (slot-value heap 'root)
112 (cut-parent node))))
113 node)
114
115 (defun extract-node (heap node)
116 (decrease-key heap node #.most-negative-fixnum)
117 (extract-min heap))
118
119 (defun meld (heap-a heap-b)
120 "Melds HEAP-A and HEAP-B into HEAP-A and returns it. HEAP-B will be
121 empty after this operation but may be used further."
122 (unless (zerop (slot-value heap-b 'size))
123 (if (zerop (slot-value heap-a 'size))
124 (setf (slot-value heap-a 'root)
125 (slot-value heap-b 'root))
126 (setf (slot-value heap-a 'root)
127 (link (slot-value heap-a 'root)
128 (slot-value heap-b 'root))))
129 (incf (slot-value heap-a 'size)
130 (slot-value heap-b 'size))
131 (clear-heap heap-b))
132 heap-a)
133
134
135 ;;; internal structure maintaining functions
136
137 (defun attach-child (parent child)
138 (declare (type node parent child)
139 (optimize (speed 3) (space 0)))
140 (when (node-lchild parent)
141 (setf (node-parent (node-lchild parent))
142 child))
143 (shiftf (node-rchild child) (node-lchild parent) child)
144 (setf (node-parent child) parent))
145
146 (defun link (node-a node-b)
147 (declare (type (or null node) node-a node-b)
148 (optimize (speed 3) (space 0)))
149 (cond
150 ((null node-b)
151 node-a)
152 ((null node-a)
153 node-b)
154 ((= (node-rank node-a)
155 (node-rank node-b))
156 (link-fair node-a node-b))
157 (t
158 (link-unfair node-a node-b))))
159
160 (defun link-fair (node-a node-b)
161 (declare (type node node-a node-b)
162 (optimize (speed 3) (space 0)))
163 (cond
164 ((< (node-key node-a) (node-key node-b))
165 (incf (node-rank node-a))
166 (attach-child node-a node-b))
167 (t
168 (incf (node-rank node-b))
169 (attach-child node-b node-a))))
170
171 (defun link-unfair (node-a node-b)
172 (declare (type node node-a node-b)
173 (optimize (speed 3) (space 0)))
174 (cond
175 ((< (node-key node-a) (node-key node-b))
176 (when (< (node-rank node-a)
177 (node-rank node-b))
178 (setf (node-rank node-a)
179 (node-rank node-b)))
180 (attach-child node-a node-b))
181 (t
182 (when (< (node-rank node-b)
183 (node-rank node-a))
184 (setf (node-rank node-b)
185 (node-rank node-a)))
186 (attach-child node-b node-a))))
187
188 (defun cut-parent (node)
189 (declare (type node node)
190 (optimize (speed 3) (space 0)))
191 (if (eq (node-lchild (node-parent node)) node)
192 (shiftf (node-lchild (node-parent node))
193 (node-rchild node)
194 nil)
195 (shiftf (node-rchild (node-parent node))
196 (node-rchild node)
197 nil))
198 ;; restore rank rule for decreased node
199 (setf (node-rank node)
bfba26a LET* => LET
Stephan Frank authored
200 (1+ (the fixnum (d-rank (node-lchild node)))))
a635768 added rank pairing heap
Stephan Frank authored
201 ;; type-2 rank reduction
202 (loop for u = (shiftf (node-parent node) nil) then (node-parent u)
203 for rv = (d-rank (node-lchild u))
204 until (null (node-parent u))
205 for rw = (d-rank (node-rchild u))
206 for k = (if (> (abs (- rv rw)) 1)
207 (max rv rw)
208 (1+ (max rv rw)))
209 while (< k (node-rank u))
210 do (print k) (setf (node-rank u) k)
211 finally
212 ;; set rank in case u is a root
213 (unless (node-parent u)
214 (setf (node-rank u) rv))
215 (return node)))
216
217 (declaim (inline d-rank))
218 (defun d-rank (node)
219 (declare (type (or null node) node)
220 (optimize (speed 3) (space 0)))
221 (if node
222 (node-rank node)
223 -1))
Something went wrong with that request. Please try again.