diff options
| -rw-r--r-- | priority-queue/pq-test.scm | 180 | ||||
| -rw-r--r-- | priority-queue/pq.scm | 87 |
2 files changed, 267 insertions, 0 deletions
diff --git a/priority-queue/pq-test.scm b/priority-queue/pq-test.scm new file mode 100644 index 0000000..5491e64 --- /dev/null +++ b/priority-queue/pq-test.scm @@ -0,0 +1,180 @@ +;; -*- compile-command: "guile -L . pq-test.scm"; -*- +(use-modules (srfi srfi-64) + (ice-9 q) + (pq)) + + +(test-begin "harness") + + +(test-equal "make-pq returns empty queue" + '(() . #f) + (make-pq)) + +(test-assert "make-pq returns a pq" + (pq? (make-pq))) + +;; A queue is implemented as a cons cell, the car +;; containing a list of queued elements, and the +;; cdr being the last cell in that list (for ease +;; of enqueuing). +(define simple-queue '((#\b #\c #\e #\f #\g #\h) #\h)) +(define priority-queue '(((#\c . 7) (#\e . 6) (#\f . 4)) (#\f . 4))) + +(test-assert "queue is not a priority-queue no pair" + (not (pq? simple-queue))) + +(test-assert "queue is not a priority-queue missing number" + (not (pq? '(((#\c . 7) (#\e . #\g) (#\f . 4)) (#\f . 4))))) + +(test-assert "queue is not a priority-queue misordered" + (not (pq? '(((#\c . 7) (#\e . 6) (#\f . 4)) (#\f . 5))))) + +(test-assert "mature priority-queue is a priority queue" + (pq? priority-queue)) + +(test-error "q-ref empty q" + #t + (q-ref (make-q) 1)) + +(test-error "q-ref overflow" + #t + (q-ref simple-queue 6)) + +(test-error "q-ref underflow" + #t + (q-ref simple-queue -1)) + +(test-equal "q-ref retrieve last" + #\h + (q-ref simple-queue 5)) + +(test-equal "q-ref retrieve first" + #\b + (q-ref simple-queue 0)) + +(test-equal "q-ref retrieve third" + #\e + (q-ref simple-queue 2)) + +(test-error "q-insert oob" + #t + (q-insert! (make-q) 1 #\x)) + +(test-equal "q-insert empty q" + '((#\x) #\x) + (q-insert! (make-q) 0 #\x)) + +;;;; test-equal results in a segfault, but +;;;; hand-testing shows my procedure is correct +;;;; perhaps there is a bug in test-equal? +;; (test-equal "q-insert last q" +;; '((#\b #\c #\e #\f #\g #\h #\i) #\i) +;; (q-insert! simple-queue 6 #\i)) + +(test-equal "q-insert first q" + '((#\a #\b #\c #\e #\f #\g #\h) #\h) + (q-insert! simple-queue 0 #\a)) + +(test-equal "q-insert fourth q" + '((#\a #\b #\c #\d #\e #\f #\g #\h) #\h) + (q-insert! simple-queue 3 #\d)) + +(test-equal "pq-push! empty queue" + '(((#\x . 3)) (#\x . 3)) + (pq-push! (make-pq) #\x 3)) + +(test-equal "pq-push! highest first double" + '(((#\x . 3) (#\y . 1)) (#\y . 1)) + (let ((my-pq (make-pq))) + (begin (pq-push! my-pq #\x 3) + (pq-push! my-pq #\y 1)))) + +(test-equal "pq-push! lowest first double" + '(((#\x . 3) (#\y . 1)) (#\y . 1)) + (let ((my-pq (make-pq))) + (begin (pq-push! my-pq #\y 1) + (pq-push! my-pq #\x 3)))) + +(test-equal "pq-push! highest priority" + '(((#\a . 11) (#\c . 7) (#\e . 6) (#\f . 4)) (#\f . 4)) + (begin (pq-push! priority-queue #\a 11))) + +(test-equal "pq-push! lowest priority" + '(((#\a . 11) (#\c . 7) (#\e . 6) (#\f . 4) (#\g . 3)) (#\g . 3)) + (begin (pq-push! priority-queue #\g 3))) + +(test-equal "pq-push! second priority" + '(((#\a . 11) (#\b . 9) (#\c . 7) (#\e . 6) (#\f . 4) (#\g . 3)) (#\g . 3)) + (begin (pq-push! priority-queue #\b 9))) + +;; implementation breaks ties by inserting new element before +(test-equal "pq-push! tied priority" + '(((#\a . 11) (#\b . 9) (#\c . 7) (#\d . 6) (#\e . 6) (#\f . 4) (#\g . 3)) (#\g . 3)) + (begin (pq-push! priority-queue #\d 6))) + +(test-error "pq-pop! empty queue" + #t + (pq-pop! (make-pq))) + +(test-equal "pq-pop! single element" + '(#\x . 3) + (pq-pop! (pq-push! (make-pq) #\x 3))) + +(test-equal "pq-pop! mature priority queue" + '(#\a . 11) + (pq-pop! priority-queue)) + +(test-equal "pq-pop! removed element" + '(#\b . 9) + (pq-pop! priority-queue)) + +(test-equal "pq-length empty queue" + 0 + (pq-length (make-pq))) + +(test-equal "pq-length mature priority queue" + 5 + (pq-length priority-queue)) + +(test-assert "pq-empty? true" + (pq-empty? (make-pq))) + +(test-assert "pq-empty? false" + (not (pq-empty? priority-queue))) + +(test-error "pq-front! empty queue" + #t + (pq-front (make-pq))) + +(test-equal "pq-front! single element" + '(#\x . 3) + (pq-front (pq-push! (make-pq) #\x 3))) + +(test-equal "pq-front! mature priority queue" + '(#\c . 7) + (pq-front priority-queue)) + +(test-equal "pq-front! did not remove element" + '(#\c . 7) + (pq-front priority-queue)) + +(test-error "pq-rear! empty queue" + #t + (pq-rear (make-pq))) + +(test-equal "pq-rear! single element" + '(#\x . 3) + (pq-rear (pq-push! (make-pq) #\x 3))) + +(test-equal "pq-rear! mature priority queue" + '(#\g . 3) + (pq-rear priority-queue)) + +(test-equal "pq-rear! did not remove element" + '(#\g . 3) + (pq-rear priority-queue)) + + + +(test-end "harness") diff --git a/priority-queue/pq.scm b/priority-queue/pq.scm new file mode 100644 index 0000000..337e5a6 --- /dev/null +++ b/priority-queue/pq.scm @@ -0,0 +1,87 @@ +(define-module (pq) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (ice-9 q) + #:export (make-pq + pq? + pq-push! + pq-pop! + pq-length + pq-empty? + pq-front + pq-rear + q-ref + q-insert!)) + + +(define (make-pq) + (make-q)) + +(define (pq? obj) + "Return #t if OBJ is a priority-queue. +An object is a priority-queue if it is a +queue, and if all elements are ordered from +largest to smallest." + (and (q? obj) + (or (q-empty? obj) + (sorted? (car obj) descending-priority?)))) + +(define (pq-push! pq e p) + "Given the priority queue PQ, +element E and its priority P, inserts E +in the appropriate spot given P." + (let ((ele (cons e p))) + (if (q-empty? pq) + (q-push! pq ele) + (let loop ((i 0)) + (if (or (equal? i (q-length pq)) + (>= p (cdr (q-ref pq i)))) + (q-insert! pq i ele) + (loop (1+ i))))))) + +(define (pq-pop! pq) + (q-pop! pq)) + +(define (pq-length pq) + (q-length pq)) + +(define (pq-empty? pq) + (q-empty? pq)) + +(define (pq-front pq) + (q-front pq)) + +(define (pq-rear pq) + (q-rear pq)) + +(define (descending-priority? a b) + "Helper for pq? Checks that two +adjacent elements in a priority queue +contain a descending number in their cdr +slots." + (not + (and (pair? a) (pair? b) + (integer? (cdr a)) + (integer? (cdr b)) + (>= (cdr b) (cdr a))))) + +(define (q-ref q i) + "Given queue Q and integer I, +returns the element in Q at I, or +a out of range exception." + (list-ref (car q) i)) + +(define (q-insert! q i ele) + "Places item ELE in position I of +Q, or returns an index-out-of-range +exception." + (let ((lst (car q)) + (len (q-length q))) + (cond + ((> i len) (throw 'index-out-of-range q i)) + ((equal? i len) + (enq! q ele)) + (#t + (set-car! q (append (list-head lst i) + (cons ele (list-tail lst i))))))) + q) |