問題3.23

(cons back-pointer (cons item next-pointer))
;この形を一つのqueueオブジェクトとする。
;項目が3個なのでclosureでやる手もあるが、メモリコピーが多発し消費が激しいためlistのポインタを使う。
;schemeはconsを扱うことでメモリ操作が出来るらしい。

(define (make-deque)
  (let ((front-ptr '())
        (rear-ptr '()))

    (define (next ptr) (cddr ptr))
    (define (back ptr) (car ptr))
    (define (item ptr) (cadr ptr))

    (define (empty?) (or (null? front-ptr) (null? rear-ptr)))

    (define (set-front-ptr! item) (set! front-ptr item))
    (define (set-rear-ptr! item) (set! rear-ptr item))

    (define (insert-front! item)
      (let ((new-queue (cons '() (cons item front-ptr))))
        (if (empty?)
            (begin (set-front-ptr! new-queue)
                   (set-rear-ptr!  new-queue)
                   #f)
            (begin (set-car! front-ptr new-queue)
                   (set-front-ptr! new-queue)
                   #f))))

    (define (insert-rear! item)
      (let ((new-queue (cons rear-ptr (cons item '()))))
        (if (empty?)
            (begin (set-front-ptr! new-queue)
                   (set-rear-ptr!  new-queue)
                   #f)
            (begin (set-cdr! (cdr rear-ptr) new-queue)
                   (set-rear-ptr! new-queue)
                   #f))))

    (define (delete-front!)
      (if (empty?)
          (error "DELETE-FRONT! called with an empty queue.")
          (begin (set-front-ptr! (next front-ptr))
                 (unless (empty?) (set-car! front-ptr '())) ;; send delete request to gc.
                 #f)))

    (define (delete-rear!)
      (if (empty?)
          (error "DELETE-REAR! called with an empty queue.")
          (begin (set-rear-ptr! (back rear-ptr))
                 (unless (empty?) (set-cdr! (cdr rear-ptr) '()))  ;; send delete request to gc.
                 #f)))

    (define (front)
      (if (empty?)
          (error "FRONT called with an empty queue")
          (item front-ptr)))

    (define (rear)
      (if (empty?)
          (error "REAR called with an empty queue")
          (item rear-ptr)))

    (define (print-from-top ptr)
      (if (null? ptr)
          #f
          (begin (display " ")
                 (display (item ptr))
                 (print-from-top (next ptr)))))

    (define (print-from-last ptr)
      (if (null? ptr)
          #f
          (begin (display " ")
                 (display (item ptr))
                 (print-from-last (back ptr)))))

    (define (print-queue . from-last)
      (if (empty?)
          (begin (display "DQ()\n") #f)
          (if (null? from-last)
              (begin (display "DQ(")
                     (print-from-top front-ptr)
                     (display " )\n"))
              (begin (display "DQ (from-last) (")
                     (print-from-last rear-ptr)
                     (display " )\n")))))

    (define (dispatch m)
      (cond ((eq? m 'insert-front!) insert-front!)
            ((eq? m 'insert-rear!) insert-rear!)
            ((eq? m 'delete-front!) delete-front!)
            ((eq? m 'delete-rear!) delete-rear!)
            ((eq? m 'front) front)
            ((eq? m 'rear) rear)
            ((eq? m 'empty?) empty?)
            ((eq? m 'print) print-queue)
            (else (error "Undefined operation -- " m))))

    dispatch))


(define dq1 (make-deque))
((dq1 'print))
((dq1 'insert-front!) 1)


(define dq1 (make-deque))
((dq1 'insert-rear!) 1)
((dq1 'insert-rear!) 2)
((dq1 'insert-rear!) 3)
((dq1 'print))
;-> DQ( 1 2 3 )

((dq1 'insert-front!) 0)
((dq1 'insert-front!) -1)
((dq1 'insert-front!) -2)
((dq1 'print))
;-> DQ( -2 -1 0 1 2 3 )

((dq1 'print) #t)
;-> DQ (from-last) ( 3 2 1 0 -1 -2 )

((dq1 'delete-front!))
((dq1 'delete-front!))
((dq1 'print))
;-> DQ( 0 1 2 3 )

((dq1 'delete-rear!))
((dq1 'delete-rear!))
((dq1 'print))
;-> DQ( 0 1 )

((dq1 'delete-front!))
((dq1 'print))
;-> DQ( 1 )

((dq1 'delete-front!))
((dq1 'print))
;-> DQ()

((dq1 'delete-front!))
; *** ERROR: DELETE-FRONT! called with an empty queue.

;ok!