7
\$\begingroup\$

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-float types. 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.

\$\endgroup\$
2
\$\begingroup\$

Packaging

  • The project and repository is called cl-binheap, while the ASDF system is called binheap - it's a good idea for those to match, mostly due to UX: I'll try loading the repository name first all the time.
  • Worse is the package name binhp. Now we have three names instead of one. Simply pick one of them and go with it (not binhp though, why's leaving out two vowels make things better?).
  • Depending on who you'd like to use the code, the Unlicense might not be so advisable.
  • The README.md looks okayish, I'd rather also see an API reference with some more details though.

Code

  • The tests use assert, instead I'd recommend one of the existing frameworks, possibly also linking it into ASDF so that asdf:test-system works.
  • Some of the source files correctly have in-package, some don't - I'd suggest always specifying which package to use, even (or especially) if it's example code.
  • example.lisp doesn't work for me on CCL (I'd also suggest testing code with at least two or more implementations if you want it to be widely used): #(6 5 3 2 4 1) is not an adjustable array. Adding :adjustable t to the definition of *arr* fixes that.
  • binheap.lisp has some trailing whitespace and some tabs. Consider M-x delete-trailing-whitespace and M-x untabify.
  • (floor (/ x y)) could be simplified to (floor x y) here (note the second return value is gonna be different though).
  • (not (= ind 0)) will hopefully be optimised. If not, however, (not (eql ind 0)) might be better (of course (/= ind 0) also exists, but still does numeric comparison).
  • I'd suggest adding a key to make the container more generic / match the standard sequence operators. This helps immensely when adding some objects and then using one of the attributes for comparison; it composes better than a single test argument.
  • Lastly, CLOS is great and all, but strictly speaking all of the methods could be functions and therefore be a bit quicker. Unless of course you have plans to add more containers with the same interface. Consider also annotating everything with types and looking at what the compiler (well, SBCL only really) will tell you about problems when compiling with higher optimisation settings ((declaim (optimize ...))). However, I'd say that unless you're very certain do not however put (declare (optimize ...)) into the library code, it's easy to get that wrong.
  • Don't use assert if the error isn't correctable by changing the value interactively. Like in make-heap, both of those should be regular errors: Retrying won't fix the problem (that's a common restart established with assert) and changing vec or test isn't something you'd do interactively ... I think. So, check-type and error would be the way to go here.
  • For randomised testing there's AFAIK nothing like a standard package, look for Quickcheck clones or "random testing common lisp" probably.

Edit: Oh I just saw you said to be nitpicky. Alright then:

  • It's "Common Lisp", no dash :)
  • ind, *arr*, arr, arrval, etc. aren't great names. Especially in function signatures consider matching what the standard uses for similar purposes. I'm betting that it's index and array respectively. Common Lisp has a tendency to have long names (for good!) and I'm (nitpicky) of the opinion that it's good style to match that (as much as possible).
  • loop should be replaced by iterate because it has more parentheses. Not kidding, it simply looks better.
  • The docstrings are suboptimal and again should match an existing style. I: * Heap instance... I haven't seen before and it doesn't even mention which parameter (name) it describes. Take some exemplary documentation as a guideline perhaps.
\$\endgroup\$
  • \$\begingroup\$ Thank you very much for this very detailed answer. I have many things to look into at many levels now! \$\endgroup\$ – Thomas Houllier Sep 27 at 15:10
  • \$\begingroup\$ Hope it helps; btw. you can always post again here with a follow-up if you want too. \$\endgroup\$ – ferada Sep 27 at 19:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.