src/sicp/ex3_22.rkt

   1 #lang r5rs
   2
   3 (define error display)
   4 (define (make-queue)
   5   (let ((front-ptr '())
   6         (rear-ptr '()))
   7     (define (set-front-ptr! queue item)
   8       (set! front-ptr item))
   9     (define (set-rear-ptr! queue item)
  10       (set! rear-ptr item))
  11     (define (empty-queue? queue)
  12       (null? front-ptr))
  13     (define (front-queue queue)
  14       (if (empty-queue? queue)
  15           (error "FRONT called with an empty queue" queue)
  16           (car front-ptr)))
  17     (define (insert-queue! queue item)
  18       (let ((new-pair (cons item '())))
  19         (cond ((empty-queue? queue)
  20                (set-front-ptr! queue new-pair)
  21                (set-rear-ptr! queue new-pair)
  22                front-ptr)
  23               (else
  24                (set-cdr! rear-ptr new-pair)
  25                (set-rear-ptr! queue new-pair)
  26                front-ptr))))
  27     (define (delete-queue! queue)
  28       (cond ((empty-queue? queue)
  29              (error "DELETE! called with an empty queue" queue))
  30             (else
  31              (set-front-ptr! queue (cdr front-ptr))
  32              front-ptr)))
  33     (define (dispatch m)
  34       (cond
  35         ((eq? m 'insert-queue!)
  36          (lambda (queue item)
  37            (insert-queue! queue item)))
  38         ((eq? m 'delete-queue!)
  39          (lambda (queue)
  40            (delete-queue! queue)))
  41         ((eq? m 'empty-queue?)
  42          (lambda (queue)
  43            (empty-queue? queue)))
  44         ((eq? m 'front-queue)
  45          (lambda (queue)
  46            (front-queue queue)))))
  47     dispatch))
  48
  49 (define (empty-queue? queue)
  50   ((queue 'empty-queue?) queue))
  51
  52 (define (front-queue queue)
  53   ((queue 'front-queue) queue))
  54
  55 (define (insert-queue! queue item)
  56   ((queue 'insert-queue!) queue item))
  57
  58 (define (delete-queue! queue)
  59   ((queue 'delete-queue!) queue))