I implemented a basic binary heap in Common Lisp to learn programming using the CLOS. It is quite neat and self-contained, the core of the program is about 100 SLOC. The whole repository can be found here.
The crux of the program is binheap.lisp:
;;;; Binary heap implementation.
;;;; We implemented this structure using the excellent article at:
;;;; https://en.wikipedia.org/wiki/Binary_heap
;;;; The binary heap is implemented as a CLOS class.
;;;; Please note that the vector you provide to the heap object is used in-place
;;;; throughout the life of the heap. It is up to you to make copies and ensure
;;;; the vector is not modified externally.
(in-package :binhp)
(defclass heap ()
((vec
:documentation "Resizeable array to store the implicit Binary Heap."
:initarg :vec
:initform (error "class heap: Please provide a vector")
:accessor vec)
(test
:documentation "Total order function. The heap enforces:
{funcall totorder parent child} throughout the binary tree."
:initarg :test
:initform (error "class heap: Please provide a total order relation.")
:accessor test)))
(defun make-heap (vec test)
"Heap constructor.
I: vec: Vector to back the implicit binary tree structure. Works in place.
Must have a fill-pointer.
test: The total order to enforce throughout the heap.
[funcall test parent child] is true throughout the tree."
(assert (array-has-fill-pointer-p vec))
(assert (typep test 'function))
(let ((hp (make-instance 'heap :vec vec :test test)))
(build hp)
hp))
;;; Main
(defmethod build ((tree heap))
"Initial building of the binary heap from the input vector of data.
Sub-method."
;; We work our way up the tree calling the down-heap method on each parent
;; node.
;; Parent nodes are the ones from 0 to floor{n-2 / 2} included.
(loop for ind from (floor (/ (- (length (vec tree)) 2) 2)) downto 0 do
(down-heap tree ind)))
(defmethod insert ((tree heap) newkey)
"Push a new element to the heap.
I: * Heap instance.
* New element."
(with-slots ((arr vec)
(test test)) tree
;; Inserts a new element at the end of arr and performs a up-heap.
;; Last element of the array is guaranteed to be a leaf of the tree.
(vector-push-extend newkey arr)
;; Compare the new element with its parent node.
;; * If order is respected or if we've reached the root of the tree
;; then return.
;; * Else swap. And repeat.
(let* ((ind (1- (length arr)))
(parind (floor (/ (1- ind) 2))))
(loop while (and (not (= ind 0))
(not (funcall test (aref arr parind)
(aref arr ind)))) do
(rotatef (aref arr parind) (aref arr ind))
(setf ind parind)
(setf parind (floor (/ (1- ind) 2)))))))
(defmethod down-heap ((tree heap) ind)
"Perform the down-heap operation. Move the parent node at 'ind' downwards
until it settles in a suitable position. Sub-method, not exposed to user."
;; Compare the current key with its two children. Return if order is respected
;; else swap the current key with the child that respects the total order with
;; the other child. Also return if we have reached a leaf of the tree.
;; Nodes at an index starting at ceil{n-2 / 2} are leafs.
(with-slots ((arr vec)
(test test)) tree
(let* ((maxind (1- (length arr)))
(leaf-limit (floor (/ (1- maxind) 2)))
(left-child (+ (* 2 ind) 1))
(right-child (min (1+ left-child) maxind)))
(loop while
(and
;; Order of tests matters here!
(not (> ind leaf-limit))
(not (and (funcall test (aref arr ind) (aref arr left-child))
(funcall test (aref arr ind) (aref arr right-child)))))
do
;; Find out the right child to swap with and swap.
(if (funcall test (aref arr left-child) (aref arr right-child))
(progn (rotatef (aref arr ind) (aref arr left-child))
(setf ind left-child))
(progn (rotatef (aref arr ind) (aref arr right-child))
(setf ind right-child)))
(setf left-child (+ (* 2 ind) 1))
(setf right-child (min (1+ left-child) maxind))))))
(defmethod extract ((tree heap))
"Pop the root element from the heap. Rearranges the tree afterwards.
I: Heap instance.
O: Root element."
(with-slots ((arr vec)) tree
(let ((root (aref arr 0)))
;; replace the root with the last leaf
;; resize vector
;; down-heap the new root.
(setf (aref arr 0) (aref arr (1- (length arr))))
(vector-pop arr)
(down-heap tree 0)
root)))
(defmethod print-tree ((tree heap))
"Print the whole tree in a very basic formatting, level by level
and left to right."
(with-slots ((arr vec)) tree
(let* ((n (length arr))
(h (floor (log n 2))))
;; The heap is already ordered by level. And each level is in the right
;; order.
(loop for level from 0 upto h do
(loop for ind from (1- (expt 2 level))
below (1- (expt 2 (1+ level))) do
(if (< ind n)
(format t "~a " (aref arr ind))))
(terpri t)))))
(defmethod size ((tree heap))
(length (vec tree)))
And you can see some examples in example.lisp:
;;;; Examples illustrating the use of the binary heap implementation.
;;; Loading the library, adjust the paths to your own directories.
;;; Can also be done by loading the source files directly.
(if (not (member #p"~/portacle/projects/"
asdf:*central-registry*))
(push #p"~/portacle/projects/"
asdf:*central-registry*))
(ql:quickload :binheap)
;;; Max-heaps
;; Let's build a heap of integers ordered from biggest to smallest.
(defparameter *arr* (make-array 6 :fill-pointer 6
:initial-contents (list 3 4 1 2 5 6)))
(defparameter *heap* (binhp:make-heap *arr* #'>=))
;; #'>= is the relation enforced throughout the heap between every parent node
;; and its children.
(binhp:print-tree *heap*)
;; =>
;; 6
;; 5 3
;; 2 4 1
;; Alright, this is a nice heap.
;; You can insert elements in it:
(binhp:insert *heap* 3.5)
(binhp:print-tree *heap*)
;; =>
;; 6
;; 5 3.5
;; 2 4 1 3
;; The new element fits in the heap.
;; You can pop elements to get the successive biggest of the heap:
(loop for it from 0 below (length *arr*) do
(format t "~a " (binhp:extract *heap*)))
(terpri t)
;; => 6 5 4 3.5 3 2 1
;;; The same goes for Min-heaps, just replace #'>= with #'<=.
;;; You can define any relation that is a total order in 'test.
;;; Alphabetical heap.
;; The heap implementation works for any element types and any total order.
;; Let's put some strings in an alphabetical order heap.
(defparameter *arr*
(make-array 5
:fill-pointer 5
:initial-contents (list "Pierre" "Jacques" "Paul" "Jean" "Luc")))
(defparameter *heap* (binhp:make-heap *arr* #'string-lessp))
(binhp:print-tree *heap*)
;; =>
;; Jacques
;; Jean Paul
;; Pierre Luc
(loop for it from 0 below (length *arr*) do
(format t "~a " (binhp:extract *heap*)))
(terpri t)
;; => Jacques Jean Luc Paul Pierre
As well as some tests in test.lisp:
;;;; Simple tests for validating binheap.
;;; Loading the library, adjust the paths to your own directories.
(if (not (member #p"~/portacle/projects/"
asdf:*central-registry*))
(push #p"~/portacle/projects/"
asdf:*central-registry*))
(ql:quickload :binheap)
;;; Validation
(format t "Creating empty or small binary heaps:...")
(dotimes (it 10 t)
(let ((arr (make-array it :fill-pointer it)))
(binhp:make-heap arr #'>=)))
(format t " OK") (terpri t)
(format t "Simple heaps and operations:...")
(loop for test in (list #'>= #'<=) do
(loop for nelem from 10 upto 50 do
(let ((arr (make-array nelem :fill-pointer nelem))
(arrval (make-array nelem))
(hp nil))
(loop for ind from 0 below nelem do
(setf (aref arr ind) (random 100))
(setf (aref arrval ind) (aref arr ind)))
(setf hp (binhp:make-heap arr test))
;; Now pop all the elements and verify that we get the right order
(sort arrval test)
(loop for ind from 0 below nelem do
(assert (= (binhp:extract hp) (aref arrval ind))))
;; Reinsert shuffled elements.
(loop for ind from 0 below nelem do
(rotatef (aref arrval ind) (aref arrval (random nelem))))
(loop for elem across arrval do
(binhp:insert hp elem))
;; Now repop everything and check order.
(sort arrval test)
(loop for ind from 0 below nelem do
(assert (= (binhp:extract hp) (aref arrval ind)))))))
(format t "OK") (terpri t)
;;; Performance
(terpri t) (format t "Performance:") (terpri t)
(loop for nelem in (list 100 10000 1000000) do
(let ((arr (make-array nelem :element-type 'double-float
:fill-pointer nelem
:initial-element 0d0))
(hp nil))
(loop for ind from 0 below nelem do
(setf (aref arr ind) (random 100d0)))
(format t "Building a max-heap of ~a double-floats: " nelem) (terpri t)
(time (setf hp (binhp:make-heap arr #'>=)))
(format t "Popping a max-heap of ~a double-floats: " nelem) (terpri t)
(time (dotimes (it nelem t) (binhp:extract hp)))
(format t "Reinserting ~a double-floats:" nelem) (terpri t)
(time (dotimes (it nelem t) (binhp:insert hp (random 100d0))))))
Review
- I am mostly happy with
binheap.lisp(but should I be?). Are there any obvious shortcuts that could be used to make the code more elegant/efficient? - The tests are quite awkward. I validate the library for random cases and do a few performance benchmarks for
double-floattypes. Is there any package that you could recommend for the same kind of tests but in a less awkward way to program and read?
All this testing might be overkill for such a simple and small program, but my goal is to have a self-contained example of a typical, very neat Common-Lisp project. So by all means be nitpicky please.
