diff --git a/algo/priority-queue.scm b/algo/priority-queue.scm index 1d2202d..b633fed 100644 --- a/algo/priority-queue.scm +++ b/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)) - (priority (vector-ref A l)) - (priority (vector-ref A i)))) + (cmp (priority (vector-ref A r)) (priority (vector-ref A l))) + (cmp (priority (vector-ref A r)) (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 -;; may need to "swim" up the heap to maintain the order. +;; added to the heap: it's initally added at the end of the heap and may need to +;; "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))) - (priority (vector-ref A i))))) + (when (and (> (parent i) 0) (cmp (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))))) diff --git a/test/algo/priority-queue.scm b/test/algo/priority-queue.scm new file mode 100644 index 0000000..2d87732 --- /dev/null +++ b/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")