home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / QUEUE.SCM < prev    next >
Text File  |  1992-06-17  |  3KB  |  98 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Queues
  4. ; Richard's code with Jonathan's names.
  5. ;
  6. ;     Richard's names:     Jonathan's names:
  7. ;      make-empty-queue     make-queue
  8. ;      add-to-queue!        enqueue
  9. ;      remove-from-queue!   dequeue
  10.  
  11. (define queue-type (make-record-type 'queue '(uid head tail)))
  12.  
  13. (define *queue-uid* 0)
  14.  
  15. (define make-queue
  16.   (let ((make (record-constructor queue-type '(uid head tail))))
  17.     (lambda ()
  18.       (let ((uid *queue-uid*))
  19.     (set! *queue-uid* (+ uid 1)) ;potential synchronization screw
  20.     (make uid '() '())))))
  21.  
  22. (define queue-uid  (record-accessor queue-type 'uid))
  23. (define queue-head (record-accessor queue-type 'head))
  24. (define queue-tail (record-accessor queue-type 'tail))
  25. (define set-queue-head! (record-modifier queue-type 'head))
  26. (define set-queue-tail! (record-modifier queue-type 'tail))
  27.  
  28. (define queue? (record-predicate queue-type))
  29.  
  30.  
  31. ; The procedures for manipulating queues.
  32.  
  33. (define (queue-empty? q)
  34.   (eq? '() (queue-head q)))        ;SHOULD BE NULL? - speed kludge
  35.  
  36. (define (enqueue q v)
  37.   (let ((p (cons v '())))
  38.     (if (eq? '() (queue-head q))    ;(queue-empty? q)
  39.         (set-queue-head! q p)
  40.         (set-cdr! (queue-tail q) p))
  41.     (set-queue-tail! q p)))
  42.  
  43. (define (queue-front q)
  44.   (if (queue-empty? q)
  45.       (error "queue is empty" q)
  46.       (car (queue-head q))))
  47.  
  48. (define (dequeue q)
  49.   (let ((pair (queue-head q)))
  50.     (cond ((eq? '() pair)    ;(queue-empty? q)
  51.        (error "empty queue" q))
  52.       (else
  53.        (let ((value (car pair))
  54.          (next  (cdr pair)))
  55.          (set-queue-head! q next)
  56.          (if (eq? '() next)
  57.          (set-queue-tail! q '()))   ; don't retain pointers
  58.          value)))))
  59.  
  60. (define (on-queue? v q)
  61.   (memq v (queue-head q)))
  62.  
  63. ; This removes the first occurrence of V from Q.
  64.  
  65. (define (delete-from-queue! q v)
  66.   (delete-from-queue-if! q (lambda (x) (eq? x v))))
  67.  
  68. (define (delete-from-queue-if! q pred)
  69.   (let ((list (queue-head q)))
  70.     (cond ((eq? '() list)
  71.        #f)
  72.       ((pred (car list))
  73.        (set-queue-head! q (cdr list))
  74.            (if (eq? '() (cdr list))
  75.                (set-queue-tail! q '()))   ; don't retain pointers
  76.        #t)
  77.       ((eq? '() (cdr list))
  78.        #f)
  79.       (else
  80.        (let loop ((list list))
  81.          (let ((tail (cdr list)))
  82.            (cond ((eq? '() tail)
  83.               #f)
  84.              ((pred (car tail))
  85.               (set-cdr! list (cdr tail))
  86.               (if (eq? '() (cdr tail))
  87.               (set-queue-tail! q list))
  88.               #t)
  89.              (else
  90.               (loop tail)))))))))
  91.  
  92. (define (queue->list q)        ;For debugging
  93.   (map (lambda (x) x)
  94.        (queue-head q)))
  95.  
  96. (define (queue-length q)
  97.   (length (queue-head q)))
  98.