SHARE
TWEET

Untitled

a guest Nov 27th, 2019 129 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #lang r6rs
  2.  
  3. ;-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
  4. ;-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
  5. ;-*-*                                                                 *-*-
  6. ;-*-*                     Queues (Circular Vector)                    *-*-
  7. ;-*-*                                                                 *-*-
  8. ;-*-*                       Wolfgang De Meuter                        *-*-
  9. ;-*-*                  2011  Software Languages Lab                   *-*-
  10. ;-*-*                   Vrije Universiteit Brussel                    *-*-
  11. ;-*-*                                                                 *-*-
  12. ;-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
  13. ;-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
  14.  
  15. (library
  16.  (deque)
  17.  (export new deque? enqueue! serve! peek full? empty? pop!)
  18.  (import (rnrs base)
  19.          (srfi :9)
  20.          (rnrs mutable-pairs))
  21.  
  22.  (define default-size 5)
  23.  (define-record-type deque
  24.    (make s h r)
  25.    deque?
  26.    (s storage)
  27.    (h head head!)
  28.    (r rear rear!))
  29.  
  30.  (define (new)
  31.    (make (make-vector default-size) 0 0))
  32.  
  33.  (define (empty? q)
  34.    (= (head q)
  35.       (rear q)))
  36.  
  37.  (define (full? q)
  38.    (= (mod (+ (rear q) 1) default-size)
  39.       (head q)))
  40.  
  41.  (define (enqueue! q val)
  42.    (if (full? q)
  43.      (error "full queue (enqueue!)" q))
  44.    (let ((new-rear (mod (+ (rear q) 1) default-size)))
  45.      (vector-set! (storage q) (rear q) val)
  46.      (rear! q new-rear))
  47.    q)
  48.  
  49.  (define (peek q)
  50.    (if (empty? q)
  51.      (error "empty queue (peek)" q))
  52.    (vector-ref (storage q) (head q)))
  53.  
  54.  (define (serve! q)
  55.    (if (empty? q)
  56.      (error "empty queue (serve)" q))
  57.    (let ((result (vector-ref (storage q) (head q))))
  58.      (head! q (mod (+ (head q) 1) default-size))
  59.      result))
  60.  
  61.  (define (pop! q)
  62.    (if (empty? q)
  63.      (error "empty queue (pop)" q))
  64.    (let* ((new-rear (mod (- (rear q) 1) default-size))
  65.           (result (vector-ref (storage q) new-rear)))
  66.      (rear! q new-rear)
  67.      result)))
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top