Code and tests for priority queue

1 files changed, 87 insertions, 0 deletions

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)