Add tests, fix nasty bug in sink function

algo/priority-queue.scm

@@ -5,7 +5,8 @@
             pq-push!
             pq-pop!
             pq-peek
-            pq-empty?))
+            pq-empty?
+            pq-drain!))
 
 ;; The heap implementation is the based on Chapter 6: Heapsort of "Introduction
 ;; to Algorithms" by Cormen, Leiserson, Rivest, and Stein.
@@ -31,9 +32,6 @@
 ;; The sink function is called to maintain the heap property when the root node
 ;; is removed and swapped with the last node in the heap. The new root node
 ;; might need to "sink" down to maintain the heap ordering.
-;;
-;; priority is a function that returns the priority of an element.
-;; cmp will be > for a max heap or < for a min heap.
 (define (sink A i priority cmp)
   (let ((heap-size (vector-ref A 0)))
     (let loop ((i i))
@@ -41,9 +39,8 @@
             (r (right-child i)))
         (cond
          ((and (<= r heap-size)
-               (cmp (priority (vector-ref A r))
+               (cmp (priority (vector-ref A r)) (priority (vector-ref A l)))
-                    (priority (vector-ref A l))
+               (cmp (priority (vector-ref A r)) (priority (vector-ref A i))))
-                    (priority (vector-ref A i))))
           (vector-swap! A i r)
           (loop r))
          ((and (<= l heap-size)
@@ -53,12 +50,12 @@
           (loop l)))))))
 
 ;; The swim function is used to restore the heap property when a new node is
-;; added to the heap: it's initally added at the end of the heap with and
+;; added to the heap: it's initally added at the end of the heap and may need to
-;; may need to "swim" up the heap to maintain the order.
+;; "swim" up the heap to maintain the order.
 (define (swim A i priority cmp)
   (let loop ((i i))
-    (when (and (> (parent i) 0) (not (cmp (priority (vector-ref A (parent i)))
+    (when (and (> (parent i) 0) (cmp (priority (vector-ref A i))
-                                          (priority (vector-ref A i)))))
+                                     (priority (vector-ref A (parent i)))))
       (vector-swap! A i (parent i))
       (loop (parent i)))))
 
@@ -69,6 +66,8 @@
   (let ((A (make-vector initial-capacity)))
     (vector-set! A 0 0)
     (match-lambda*
+      (('dump)
+       A)
       (('size)
        (vector-ref A 0))
       (('peek)
@@ -110,3 +109,11 @@
   (q 'peek))
 
 (define pq-empty? (compose zero? pq-length))
+
+;; Pop all elements of a queue onto a list, emptying the queue in the process.
+;; Return the resulting list.
+(define (pq-drain! q)
+  (let loop ((result '()))
+    (if (pq-empty? q)
+        (reverse result)
+        (loop (cons (pq-pop! q) result)))))

test/algo/priority-queue.scm

@@ -0,0 +1,62 @@
+(use-modules (algo priority-queue)
+             (quickcheck)
+             (quickcheck arbitrary)
+             (quickcheck property)
+             (srfi srfi-26)
+             (srfi srfi-64))
+
+(define $integers ($list $integer))
+
+(define ensure-min-priority-queue-order
+  (property
+   ((integers $integers))
+   (let ((q (make-priority-queue #:cmp <)))
+     (for-each (cute pq-push! q <>) integers)
+     (equal? (pq-drain! q) (sort integers <)))))
+
+(define ensure-min-abs-priority-queue-order
+  (property
+   ((integers $integers))
+   (let ((q (make-priority-queue #:cmp < #:priority abs)))
+     (for-each (cute pq-push! q <>) integers)
+     ;; Can't use equal? for this test as two elements with the same absolute
+     ;; value might appear in a different order.
+     (sorted? (pq-drain! q) (lambda (x y) (< (abs x) (abs y)))))))
+
+(define ensure-max-priority-queue-order
+  (property
+   ((integers $integers))
+   (let ((q (make-priority-queue #:cmp >)))
+     (for-each (cute pq-push! q <>) integers)
+     (equal? (pq-drain! q) (sort integers >)))))
+
+(define ensure-max-abs-priority-queue-order
+  (property
+   ((integers $integers))
+   (let ((q (make-priority-queue #:cmp > #:priority abs)))
+     (for-each (cute pq-push! q <>) integers)
+     ;; Can't use equal? for this test as two elements with the same absolute
+     ;; value might appear in a different order.
+     (sorted? (pq-drain! q) (lambda (x y) (> (abs x) (abs y)))))))
+
+(test-begin "min-priority-queue-order")
+
+(quickcheck ensure-min-priority-queue-order)
+
+(test-end "min-priority-queue-order")
+
+(test-begin "max-priority-queue-order")
+
+(quickcheck ensure-max-priority-queue-order)
+
+(test-end "max-priority-queue-order")
+
+(test-begin "min-abs-priority-queue-order")
+
+(quickcheck ensure-min-abs-priority-queue-order)
+
+(test-end "min-abs-priority-queue-order")
+
+(test-begin "max-abs-priority-queue-order")
+(quickcheck ensure-max-abs-priority-queue-order)
+(test-end "max-abs-priority-queue-order")