vector-queue.scm

(library
 (queue)
 (export new queue? enqueue! serve! peek full? empty?)
 (import (rnrs base)
         (srfi :9)
         (rnrs mutable-pairs))
 
 (define default-size 5)
 (define-record-type queue
   (make s h r)
   queue?
   (s storage storage!)
   (h head head!)
   (r rear rear!))

 (define (new . size)
   (define preferred-length (if (null? size) default-size (car size)))
   (make (make-vector preferred-length) 0 0))

 (define (size q)
   (vector-length (storage q)))
 
 (define (empty? q)
   (= (head q)
      (rear q)))

 (define (full? q)
   #f)

 (define (saturated? q)
   (= (mod (+ (rear q) 1) (size q))
      (head q)))
 
 (define (enqueue! q val)
   (if (saturated? q) (double-storage! q))
   (let ((new-rear (mod (+ (rear q) 1) (size q))))
     (vector-set! (storage q) (rear q) val)
     (rear! q new-rear)
     q))
 
 (define (peek q)
   (if (empty? q)
       (error "empty queue (peek)" q))
   (vector-ref (storage q) (head q)))
 
 (define (serve! q)
   (if (empty? q)
       (error "empty queue (peek)" q))
   (let ((result (vector-ref (storage q) (head q))))
     (head! q (mod (+ (head q) 1) (size q)))
     result))

 (define (double-storage! q)
   (define bigv (make-vector (* (size q) 2)))
   (define bigv-rear 0)
   (let loop ()
     (vector-set! bigv bigv-rear (serve! q))
     (set! bigv-rear (+ bigv-rear 1))
     (if (not (empty? q)) (loop)))
   (storage! q bigv)
   (rear! q bigv-rear)
   (head! q 0)))