Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 32ecdf89ef
Fetching contributors…

Cannot retrieve contributors at this time

187 lines (160 sloc) 6.421 kB
;;;; MINHEAP is by Stephan Frank <defclass@googlemail.com>, 2007-2012.
;;;;
;;;; Permission is hereby granted, free of charge, to any person obtaining
;;;; a copy of this software and associated documentation files (the
;;;; "Software"), to deal in the Software without restriction, including
;;;; without limitation the rights to use, copy, modify, merge, publish,
;;;; distribute, sublicense, and/or sell copies of the Software, and to
;;;; permit persons to whom the Software is furnished to do so, subject to
;;;; the following conditions:
;;;;
;;;; The above copyright notice and this permission notice shall be included
;;;; in all copies or substantial portions of the Software.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(defpackage :binary-heap (:use :CL)
(:export
#:binary-heap
#:clear-heap
#:empty-p
#:insert
#:peek-min
#:extract-min
#:extract-node
#:heap-size
#:decrease-key
#:meld
#:alist-to-heap
))
(in-package :binary-heap)
(deftype array-index () `(integer 0 ,(1- array-dimension-limit)))
(defconstant +initial-size+ 50 "initial queue vector size")
;;;; binary min-heap
(defstruct (node (:constructor %make-node (key data index)))
(key 0 :type fixnum)
(index 0 :type array-index)
(data nil))
(defclass binary-heap ()
((array :accessor bin-heap-array
:type (vector (or null node))
:initarg :array
:initform (make-array +initial-size+
:adjustable t
:fill-pointer 0
:element-type '(or null node)
:initial-element nil))))
(defmethod print-object ((obj binary-heap) stream)
(print-unreadable-object (obj stream :type t :identity t)
(format stream "~4I~:_size: ~A~:_" (heap-size obj))))
;(declaim (inline parent left right %make-node))
(defun parent (k)
(declare (type array-index k))
(floor (1- k) 2))
(defun left (k)
(declare (type (integer 0 #.(floor array-dimension-limit 2)) k))
(1+ (* k 2)))
(defun right (k)
(declare (type (integer 0 #.(floor array-dimension-limit 2)) k))
(* (1+ k) 2))
(defun peek-min (heap)
(let ((node (aref (bin-heap-array heap) 0)))
(values (node-data node)
(node-key node))))
(defun clear-heap (heap)
(setf (fill-pointer (bin-heap-array heap)) 0))
(defun empty-p (heap)
(zerop (fill-pointer (bin-heap-array heap))))
(defun heap-size (heap)
(length (bin-heap-array heap)))
(defun extract-min (heap)
(let ((array (bin-heap-array heap))
(node (aref (bin-heap-array heap) 0)))
(assert node)
(setf (aref array 0) (aref array (1- (length array)))
(aref array (1- (length array))) nil)
(when (> (decf (fill-pointer array)) 1)
(sink array 0))
(values (node-data node)
(node-key node))))
;(declaim (inline swap-nodes))
(defun swap-nodes (array i j)
(declare (type array-index i j))
(setf (node-index (aref array i)) j
(node-index (aref array j)) i)
(rotatef (aref array i) (aref array j)))
(defun sink (array index)
(let ((maxindex (1- (length array))))
(if (zerop maxindex)
maxindex
(loop for i = index then j
with j = 0
while (<= (left i) maxindex) do
(cond
((< maxindex (right i))
(setf j (left i)))
((<= (node-key (aref array (left i)))
(node-key (aref array (right i))))
(setf j (left i)))
(t
(setf j (right i))))
(when (<= (node-key (aref array i))
(node-key (aref array j)))
(loop-finish))
(swap-nodes array i j)
finally (return array)))))
(defun perlocate-up (array vindex)
(loop for index = vindex then parent
for parent = (parent index)
with key = (node-key (aref array vindex))
while (and (>= parent 0)
(< key (node-key (aref array parent))))
do (swap-nodes array index parent)
finally (return (aref array index))))
(defun insert (heap key data)
(let ((node (%make-node key data 0))
(array (bin-heap-array heap)))
(perlocate-up array (setf (node-index node)
(vector-push-extend node array)))))
(defun decrease-key (heap node key)
(let ((vector (bin-heap-array heap)))
(when (< (node-key node) key)
(error "Cannot decrease key: new key greater than current key."))
(setf (node-key node) key)
(perlocate-up vector (node-index node))))
(defun extract-node (heap node)
(let ((key (node-key node))
(value (node-data node)))
(decrease-key heap node most-negative-fixnum)
(extract-min heap)
(values value key)))
(defun meld (heap-a heap-b)
"Melds HEAP-A and HEAP-B into a new heap and returns it. HEAP-A is
returned as new union of both heaps."
(let ((vector (bin-heap-array heap-a)))
(loop for v across (bin-heap-array heap-b)
do (vector-push-extend v vector))
(vector-to-heapvector vector)
heap-a))
(defun alist-to-heap (alist)
"Coerces an ALIST of (KEY . VALUE) conses into a heap."
(let ((node-list (loop for (key . value) in alist
collect (%make-node key value 0)))
(length (length alist)))
(let ((vector (make-array length
:adjustable t
:fill-pointer length
:element-type '(or null node)
:initial-contents node-list)))
(make-instance 'binary-heap :array (vector-to-heapvector vector)))))
(defun vector-to-heapvector (vector)
(loop for index from (floor (length vector) 2) downto 0
do (sink vector index)
finally (loop for n across vector
for i from 0 do (setf (node-index n) i))
(return vector)))
Jump to Line
Something went wrong with that request. Please try again.