1 
;;; Copyright 20092010 Rudolph Neeser <rudy.neeser@gmail.com>.

2 
;;; Copyright 2012 CLHEAP (See AUTHORS file).

3 
;;;

4 
;;; This file is part of CLHEAP

5 
;;;

6 
;;; CLHEAP 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 
;;; CLHEAP 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 CLHEAP. If not, see <http://www.gnu.org/licenses/>.

18 

19 
;;;

20 

21 
(inpackage #:clheap)

22 

23 
;;;

24 

25 
(defclass fibonacciheap (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 itemdisjoint, heapordered

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 nodeitem)

39 
(parent :initform nil

40 
:accessor nodeparent)

41 
(child :initform nil

42 
:accessor nodechild)

43 
(rank :initform 0

44 
:accessor noderank

45 
:documentation "The number of children the node has.")

46 
(marked :initform nil

47 
:accessor nodemarkedp

48 
:documentation "Used to implement cascading cuts.")

49 
(next :initform nil

50 
:accessor nodenext)

51 
(last :initform nil

52 
:accessor nodelast))

53 
(:documentation "A class used for storing data in a FIBONACCIHEAP."))

54 

55 
(defmethod initializeinstance :after ((node node) &key)

56 
(withslots (next last) node

57 
(setf next node

58 
last node)))

59 

60 
(defmethod printobject ((node node) stream)

61 
(printunreadableobject (node stream :type t :identity t)

62 
(format stream "Item: ~a" (slotvalue node 'item))))

63 

64 
;;;

65 
;;; Unexported functions for handling nodes.

66 

67 
(defgeneric unmarknode (node)

68 
(:method ((node node))

69 
(setf (nodemarkedp node) nil)))

70 

71 
(defgeneric marknode (node)

72 
(:method ((node node))

73 
(setf (nodemarkedp node) t)))

74 

75 
(defgeneric isnoderootp (node)

76 
(:method ((node node))

77 
(null (nodeparent node))))

78 

79 
(defgeneric concatenatenodelists (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 (nodenext lhs) rhs

86 
(nodelast (nodenext lhs)) (nodelast rhs)

87 
(nodelast rhs) lhs

88 
(nodenext (nodelast rhs)) (nodenext lhs))

89 
lhs))

90 

91 

92 
(defgeneric deletenode (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 
(withslots (next last parent) node

100 
(let ((result (when (not (eq next node))

101 
next)))

102 
(when result ; There was something to delete.

103 
(psetf (nodelast next) last

104 
(nodenext last) next

105 
next node

106 
last node))

107 
(when parent ; Remove the item from any parents.

108 
(decf (noderank parent))

109 
(when (eq (nodechild parent) node)

110 
(setf (nodechild parent) result))

111 
(setf parent nil))

112 
result))))

113 

114 

115 

116 
(defmacro doeachnode ((symbol node) &body body)

117 
(let ((node node)

118 
(last (gensym))

119 
(next (gensym)))

120 
`(when ,node

121 
(loop

122 
with ,last = (nodelast ,node)

123 
for ,symbol = ,node then ,next

124 
for ,next = (nodenext ,node) then (nodenext ,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 fibonacciheap) (item node))

141 
"Adds a node to the heap."

142 
(withslots (root) heap

143 
(cond

144 
((null root)

145 
(setf root item))

146 
((compareitems heap (nodeitem root) (nodeitem item))

147 
(setf root (concatenatenodelists root item)))

148 
(t

149 
(setf root (concatenatenodelists 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 fibonacciheap) (heap2 fibonacciheap))

155 
(withslots ((heap1root root)

156 
(heap1count count)) heap1

157 
(withslots ((heap2root root)

158 
(heap2count count)) heap2

159 
(setf heap1root (concatenatenodelists heap1root heap2root))

160 
(unless (compareitems heap1 (nodeitem heap1root) (nodeitem heap2root))

161 
(setf heap1root heap2root

162 
heap1count (+ heap1count heap2count))))))

163 

164 
(defgeneric link (heap nodeone nodetwo)

165 
(:documentation "Places nodetwo as a child of nodeone if

166 
nodeone's item is smaller, or vice versa.")

167 
(:method ((heap fibonacciheap) (nodeone node) (nodetwo node))

168 
(withslots ((onechild child)

169 
(oneitem item)

170 
(onerank rank)) nodeone

171 
(withslots ((twochild child)

172 
(twoitem item)

173 
(tworank rank)) nodetwo

174 
(cond

175 
((compareitems heap oneitem twoitem)

176 
(deletenode nodetwo)

177 
(unless (isnoderootp nodetwo)

178 
(unmarknode nodetwo))

179 
(setf onechild (concatenatenodelists onechild nodetwo)

180 
(nodeparent nodetwo) nodeone)

181 
(incf onerank)

182 
nodeone)

183 
(t

184 
(deletenode nodeone)

185 
(setf twochild (concatenatenodelists twochild nodeone)

186 
(nodeparent nodeone) nodetwo)

187 
(incf tworank)

188 
nodetwo))))))

189 

190 
(defgeneric cutnode (heap node)

191 
(:documentation "Cuts a child from its parent and makes and places

192 
it in the root list.")

193 
(:method ((heap fibonacciheap) (node node))

194 
(let ((parent (nodeparent node)))

195 
(withslots (root) heap

196 
(deletenode node)

197 
(concatenatenodelists root node)

198 
(cond

199 
((and parent (not (isnoderootp parent)) (nodemarkedp parent))

200 
(cutnode heap parent))

201 
((and parent (not (isnoderootp parent)))

202 
(marknode parent)

203 
heap))))))

204 

205 

206 
;;;

207 
;;; Exported Functions

208 

209 
(defmethod emptyheap ((heap fibonacciheap))

210 
"Clears all items from the heap. This is a constant time operation."

211 
(withslots (root count) heap

212 
(setf root nil

213 
count 0))

214 
heap)

215 

216 
(defmethod isemptyheapp ((heap fibonacciheap))

217 
(unless (slotvalue heap 'root)

218 
t))

219 

220 
(defmethod heapsize ((heap fibonacciheap))

221 
(slotvalue heap 'count))

222 

223 
(defmethod addtoheap ((heap fibonacciheap) item)

224 
"Adds an item to a Fibonacciheap. This is a constant time

225 
operation. Returns the item added to the heap."

226 
(let ((node (makeinstance 'node :item item)))

227 
(meld heap node)

228 
(incf (slotvalue heap 'count))

229 
(values item node)))

230 

231 
(defmethod addalltoheap ((heap fibonacciheap) (items list))

232 
"Adds the following list of items into the heap. This is an O(n) operation."

233 
(withslots (count) heap

234 
(loop for i in items

235 
do (progn

236 
(meld heap (makeinstance 'node :item i))

237 
(incf count))))

238 
heap)

239 

240 
(defmethod peepatheap ((heap fibonacciheap))

241 
"See the heap's minimum value without modifying the heap. This is a

242 
constant time operation."

243 
(withslots (root) heap

244 
(when root

245 
(nodeitem root))))

246 

247 
(defmethod popheap ((heap fibonacciheap))

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 (isemptyheapp heap)

252 
(let ((item (peepatheap heap)))

253 
(withslots (root count) heap

254 
;; Delete the minimum.

255 
(concatenatenodelists root (nodechild root))

256 
(setf root (deletenode root))

257 
(when root

258 
(let ((ranks (makearray (1+ (ceiling (log count 2))) :initialelement nil))

259 
(min nil))

260 
;; Merge all trees of the same rank.

261 
(labels ((sortnode (node)

262 
(let ((position (noderank node)))

263 
(cond

264 
((aref ranks position)

265 
(let ((new (link heap node (aref ranks position))))

266 
(setf (aref ranks position) nil)

267 
(sortnode new)))

268 
(t

269 
(setf (aref ranks position) node))))))

270 
(doeachnode (node root)

271 
;; The newly added nodes should not have a parent

272 
(setf (nodeparent node) nil)

273 
(deletenode node)

274 
(sortnode node)))

275 
(loop for tree across ranks

276 
do (when (not (null tree))

277 
(cond

278 
((null min)

279 
(setf min tree))

280 
((compareitems heap

281 
(nodeitem min)

282 
(nodeitem tree))

283 

284 
(setf min (concatenatenodelists min tree)))

285 
(t

286 
(setf min (concatenatenodelists tree min))))))

287 
(setf root min)))

288 
(decf (slotvalue heap 'count))

289 
item))))

290 

291 

292 
(defmethod nmergeheaps ((first fibonacciheap) (second fibonacciheap))

293 
"Destructively marges the two heaps. This is a constant time

294 
operation."

295 
(withslots ((firstroot root)

296 
(firstkey key)

297 
(firstfun sortfun)) first

298 
(withslots ((secondroot root)

299 
(secondkey key)

300 
(secondfun sortfun)) second

301 
(unless (and (eq firstkey secondkey)

302 
(eq firstfun secondfun))

303 
(error 'heaperror :message "These two heaps were constructed using different

304 
access keys and sorting functions."))))

305 
(meld first second)

306 
first)

307 

308 
(defmethod mergeheaps ((first fibonacciheap) (second fibonacciheap))

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 
(withslots ((firstroot root)

312 
(firstkey key)

313 
(firstfun sortfun)) first

314 
(withslots ((secondroot root)

315 
(secondkey key)

316 
(secondfun sortfun)) second

317 
(unless (and (eq firstkey secondkey)

318 
(eq firstfun secondfun))

319 
(error 'heaperror :message "These two heaps were constructed using different

320 
access keys and sorting functions."))

321 
(let ((result (makeinstance 'fibonacciheap

322 
:sortfun firstfun

323 
:key firstkey)))

324 
(labels ((addfromlevel (nodelist)

325 
(when nodelist

326 
(doeachnode (node nodelist)

327 
(addfromlevel (nodechild node))

328 
(addtoheap result (nodeitem node))))))

329 
(addfromlevel firstroot)

330 
(addfromlevel secondroot))

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 decreasekey ((heap fibonacciheap) (itemindex node) value)

337 
"Changes the value of an item represented by the ITEMINDEX to

338 
VALUE. This index is returned as the second argument to

339 
ADDTOHEAP. This is an amortised constant time operation."

340 
(withslots (key sortfun) heap

341 
(unless (funcall sortfun value (funcall key (nodeitem itemindex)))

342 
(error 'keyerror :message

343 
(format nil "The given value (~a) must be less than the current value (~a)."

344 
value (funcall key (nodeitem itemindex)))))

345 
(if (eq key #'identity)

346 
(setf (nodeitem itemindex) value)

347 
(handlercase

348 
(funcall key (nodeitem itemindex) value)

349 
(error (e)

350 
(declare (ignore e))

351 
(error 'keyerror))))

352 
(cond

353 
;; A child of something. See if cascading cuts should occur.

354 
((nodeparent itemindex)

355 
(let ((parent (nodeparent itemindex)))

356 
(deletenode itemindex)

357 
(meld heap itemindex)

358 
(when (not (isnoderootp parent))

359 
(if (nodemarkedp parent)

360 
(cutnode heap parent)

361 
(marknode parent)))))

362 
(t ; In the list with the root.

363 
(withslots (root) heap

364 
(unless (compareitems heap (nodeitem root) (nodeitem itemindex))

365 
(setf root itemindex))))))

366 
heap)

367 

368 
(defmethod deletefromheap ((heap fibonacciheap) (itemindex node))

369 
"Removes an item from the heap, as pointed to by itemindex. 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 POPHEAP."

372 
(withslots (root count) heap

373 
(let ((parent (nodeparent itemindex)))

374 
(cond

375 
((eq root itemindex)

376 
(popheap heap))

377 
(t

378 
(doeachnode (child (nodechild itemindex))

379 
(setf (nodeparent child) nil))

380 
;; Add children to root level.

381 
(concatenatenodelists root (nodechild itemindex))

382 
(deletenode itemindex)

383 
(decf count)))

384 
(when (and parent (not (isnoderootp parent)))

385 
(if (nodemarkedp parent)

386 
(cutnode heap parent)

387 
(marknode parent)))))

388 
heap)
