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 >
Wrap
Text File
|
1992-06-17
|
3KB
|
98 lines
; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Queues
; Richard's code with Jonathan's names.
;
; Richard's names: Jonathan's names:
; make-empty-queue make-queue
; add-to-queue! enqueue
; remove-from-queue! dequeue
(define queue-type (make-record-type 'queue '(uid head tail)))
(define *queue-uid* 0)
(define make-queue
(let ((make (record-constructor queue-type '(uid head tail))))
(lambda ()
(let ((uid *queue-uid*))
(set! *queue-uid* (+ uid 1)) ;potential synchronization screw
(make uid '() '())))))
(define queue-uid (record-accessor queue-type 'uid))
(define queue-head (record-accessor queue-type 'head))
(define queue-tail (record-accessor queue-type 'tail))
(define set-queue-head! (record-modifier queue-type 'head))
(define set-queue-tail! (record-modifier queue-type 'tail))
(define queue? (record-predicate queue-type))
; The procedures for manipulating queues.
(define (queue-empty? q)
(eq? '() (queue-head q))) ;SHOULD BE NULL? - speed kludge
(define (enqueue q v)
(let ((p (cons v '())))
(if (eq? '() (queue-head q)) ;(queue-empty? q)
(set-queue-head! q p)
(set-cdr! (queue-tail q) p))
(set-queue-tail! q p)))
(define (queue-front q)
(if (queue-empty? q)
(error "queue is empty" q)
(car (queue-head q))))
(define (dequeue q)
(let ((pair (queue-head q)))
(cond ((eq? '() pair) ;(queue-empty? q)
(error "empty queue" q))
(else
(let ((value (car pair))
(next (cdr pair)))
(set-queue-head! q next)
(if (eq? '() next)
(set-queue-tail! q '())) ; don't retain pointers
value)))))
(define (on-queue? v q)
(memq v (queue-head q)))
; This removes the first occurrence of V from Q.
(define (delete-from-queue! q v)
(delete-from-queue-if! q (lambda (x) (eq? x v))))
(define (delete-from-queue-if! q pred)
(let ((list (queue-head q)))
(cond ((eq? '() list)
#f)
((pred (car list))
(set-queue-head! q (cdr list))
(if (eq? '() (cdr list))
(set-queue-tail! q '())) ; don't retain pointers
#t)
((eq? '() (cdr list))
#f)
(else
(let loop ((list list))
(let ((tail (cdr list)))
(cond ((eq? '() tail)
#f)
((pred (car tail))
(set-cdr! list (cdr tail))
(if (eq? '() (cdr tail))
(set-queue-tail! q list))
#t)
(else
(loop tail)))))))))
(define (queue->list q) ;For debugging
(map (lambda (x) x)
(queue-head q)))
(define (queue-length q)
(length (queue-head q)))