SICP 問題 3.23

対を使って前後へのポインタを持ったdequeを実装する．

;; dequeの実装
(define (value-ptr ptr) (caar ptr))
(define (prev-ptr ptr) (cdar ptr))
(define (next-ptr ptr) (cdr ptr))

;; ((value))というリストを作る
(define (make-ptr value) (list (list value)))

(define (make-queue)
  (cons '() '()))

(define (front-ptr queue) (car queue))

(define (rear-ptr queue) (cdr queue))

(define (empty-queue? queue)
  (null? (front-queue queue)))

(define (make-empty-queue queue)
  (set-front-ptr! queue '())
  (set-rear-ptr! queue '())
  queue)

(define (printing queue)
  (let recur ((deque (front-ptr queue)))
    (cond ((null? deque) '())
          (else
           (cons (value-ptr deque)
                 (recur (next-ptr deque)))))))

(define (set-front-ptr! queue item) (set-car! queue item))
(define (set-rear-ptr! queue item) (set-cdr! queue item))
(define (set-prev-ptr! ptr item) (set-cdr! (car ptr) item))
(define (set-next-ptr! ptr item) (set-cdr! ptr item))

(define (front-insert-queue! queue item)
  (let ((new-item (make-ptr item)))
    (cond ((empty-queue? queue)
           (set-front-ptr! queue new-item)
           (set-rear-ptr! queue new-item)
           'ok)
          (else
           (set-prev-ptr! (front-queue queue)
                          new-item)
           (set-next-ptr! new-item
                          (front-queue queue))
           (set-front-ptr! queue new-item)
           'ok))))

(define (rear-insert-queue! queue item)
  (let ((new-item (make-ptr item)))
    (cond ((empty-queue? queue)
           (set-front-ptr! queue new-item)
           (set-rear-ptr! queue new-item)
           'ok)
          (else
           (set-next-ptr! (rear-queue queue)
                          new-item)
           (set-prev-ptr! new-item
                          (rear-queue queue))
           (set-rear-ptr! queue new-item)
           'ok))))

(define (front-delete-queue! queue)
  (cond ((empty-queue? queue)
         (error "FRONT-DELETE! called with an empty queue" queue))
        (else
         (let* ((old-front-ptr (front-ptr queue))
                (new-front-ptr (next-ptr old-front-ptr)))
           (cond ((null? new-front-ptr)
                  (make-empty-queue queue)
                  (value-ptr old-front-ptr))
                 (else
                  (set-next-ptr! old-front-ptr
                                 '())
                  (set-prev-ptr! new-front-ptr
                                 '())
                  (set-front-ptr! queue new-front-ptr)
                  (value-ptr old-front-ptr)))))))

(define (rear-delete-queue! queue)
  (cond ((empty-queue? queue)
         (error "REAR-DELETE! called with an empty queue" queue))
        (else
         (let ((new-rear-ptr (prev-ptr (rear-ptr queue)))
               (old-rear-ptr (rear-ptr queue)))
           (cond ((null? new-rear-ptr)
                  (make-empty-queue queue)
                  (value-ptr old-rear))
                 (else
                  (set-prev-ptr! old-rear-ptr
                                 '())
                  (set-next-ptr! new-rear-ptr
                                 '())
                  (set-rear-ptr! queue new-rear-ptr)
                  (value-ptr old-rear-ptr)))))))

gosh> (define q1 (make-queue))
q1
gosh> (printing q1)
()
gosh> (front-insert-queue! q1 'a)
ok
gosh> (printing q1)
(a)
gosh> (front-insert-queue! q1 'b)
ok
gosh> (printing q1)
(b a)
gosh> (front-insert-queue! q1 'c)
ok
gosh> (printing q1)
(c b a)
gosh> (front-delete-queue! q1)
c
gosh> (printing q1)
(b a)
gosh> (front-delete-queue! q1)
b
gosh> (front-delete-queue! q1)
ok
gosh> (printing q1)
()
gosh> (define q1 (make-queue))
q1
gosh> (printing q1)
()
gosh> (front-insert-queue! q1 'a)
ok
gosh> (printing q1)
(a)
gosh> (front-insert-queue! q1 'b)
ok
gosh> (printing q1)
(b a)
gosh> (front-insert-queue! q1 'c)
ok
gosh> (printing q1)
(c b a)
gosh> (front-delete-queue! q1)
c
gosh> (printing q1)
(b a)
gosh> (front-delete-queue! q1)
b
gosh> (printing q1)
(a)
gosh> (front-delete-queue! q1)
a
gosh> (printing q1)
()
gosh> (rear-insert-queue! q1 'a)
ok
gosh> (printing q1)
(a)
gosh> (rear-insert-queue! q1 'b)
ok
gosh> (printing q1)
(a b)
gosh> (rear-insert-queue! q1 'c)
ok
gosh> (printing q1)
(a b c)
gosh> (rear-delete-queue! q1)
c
gosh> (printing q1)
(a b)
gosh> (rear-delete-queue! q1)
b
gosh> (printing q1)
(a)
gosh> (rear-delete-queue! q1)
a
gosh> (printing q1)
()