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)