src/sicp/ex3_23.rkt

   1 #lang r5rs
   2
   3 (define error display)
   4
   5 (define (front-ptr deque) (car deque))
   6 (define (rear-ptr deque) (cdr deque))
   7 (define (set-front-ptr! deque item) (set-car! deque item))
   8 (define (set-rear-ptr! deque item) (set-cdr! deque item))
   9
  10 (define (empty-deque? deque) (null? (front-ptr deque)))
  11
  12 (define (make-deque) (cons '() '()))
  13
  14 (define (front-deque deque)
  15   (if (empty-deque? deque)
  16       (error "FRONT called with an empty deque" deque)
  17       (car (front-ptr deque))))
  18
  19 (define (rear-deque deque)
  20   (if (empty-deque? deque)
  21       (error "REAR called with an empty deque" deque)
  22       (car (rear-ptr deque))))
  23
  24 (define (make-cell item)
  25   (cons item (cons '() '())))
  26
  27 (define (value cell)
  28   (car cell))
  29
  30 (define (next-cell cell)
  31   (car (cdr cell)))
  32
  33 (define (prev-cell cell)
  34   (cdr (cdr cell)))
  35
  36 (define (set-next! cell pair)
  37   (set-car! (cdr cell) pair))
  38
  39 (define (set-prev! cell pair)
  40   (set-cdr! (cdr cell) pair))
  41
  42 (define (front-insert-deque! deque item)
  43   (let ((new-pair (make-cell item)))
  44     (cond
  45       ((empty-deque? deque)
  46        (set-front-ptr! deque new-pair)
  47        (set-rear-ptr! deque new-pair)
  48        deque)
  49       (else
  50        (set-next! new-pair (front-ptr deque))
  51        ;(set-cdr! (cdr (front-ptr deque)) new-pair)
  52        (set-prev! (front-ptr deque) new-pair)
  53        (set-front-ptr! deque new-pair)
  54        deque))))
  55
  56 (define (rear-insert-deque! deque item)
  57   (let ((new-pair (make-cell item)))
  58     (cond
  59       ((empty-deque? deque)
  60        (set-front-ptr! deque new-pair)
  61        (set-rear-ptr! deque new-pair)
  62        deque)
  63       (else
  64        (set-prev! new-pair (rear-ptr deque))
  65        ;(set-car! (cdr (rear-ptr deque)) new-pair)
  66        (set-next! (rear-ptr deque) new-pair)
  67        (set-rear-ptr! deque new-pair)
  68        deque))))
  69
  70 (define (front-delete-deque! deque)
  71   (cond
  72     ((empty-deque? deque)
  73      (error "DELETE! called with an empty deque"))
  74     (else
  75      (set-front-ptr! deque (car (cdr (front-ptr deque))))
  76      deque)))
  77
  78 (define (rear-delete-deque! deque)
  79   (cond
  80     ((empty-deque? deque)
  81      (error "DELETE! called with an empty deque"))
  82     (else
  83      (set-rear-ptr! deque (prev-cell (rear-ptr deque)))
  84      (set-next! (rear-ptr deque) '())
  85      deque)))
  86
  87
  88 (define (print-deque queue)
  89   (define (copy-queue q1)
  90     (let ((q2 (make-deque)))
  91       (set-front-ptr! q2 (front-ptr q1))
  92       (set-rear-ptr! q2 (rear-ptr q1))
  93       q2))
  94   (let ((q (copy-queue queue)))
  95     (if (not (empty-deque? q))
  96         (begin
  97           (display (front-deque q))
  98           (display " ")
  99           (print-deque (front-delete-deque! q))))))
 100
 101 #|
 102 > (define q (make-deque))
 103 > (front-insert-deque! q 'a)
 104 (mcons (mcons 'a (mcons '() '())) (mcons 'a (mcons '() '())))
 105 > (front-insert-deque! q 'b)
 106 (mcons #0=(mcons 'b (mcons #1=(mcons 'a (mcons '() #0#)) '())) #1#)
 107 > (front-insert-deque! q 'c)
 108 (mcons
 109  #0=(mcons 'c (mcons #1=(mcons 'b (mcons #2=(mcons 'a (mcons '() #1#)) #0#)) '()))
 110  #2#)
 111 > (print-deque q)
 112 c b a
 113 > q
 114 (mcons
 115  #0=(mcons 'c (mcons #1=(mcons 'b (mcons #2=(mcons 'a (mcons '() #1#)) #0#)) '()))
 116  #2#)
 117 > (rear-delete-deque! q)
 118 (mcons #0=(mcons 'c (mcons #1=(mcons 'b (mcons '() #0#)) '())) #1#)
 119 > (print-deque q)
 120 c b
 121 > (rear-insert-deque! q 'd)
 122 (mcons
 123  #0=(mcons 'c (mcons #1=(mcons 'b (mcons #2=(mcons 'd (mcons '() #1#)) #0#)) '()))
 124  #2#)
 125 > (print-deque q)
 126 c b d
 127 > (front-insert-deque! q 'e)
 128 (mcons
 129  #0=(mcons
 130      'e
 131      (mcons
 132       #1=(mcons
 133           'c
 134           (mcons #2=(mcons 'b (mcons #3=(mcons 'd (mcons '() #2#)) #1#)) #0#))
 135       '()))
 136  #3#)
 137 > (print-deque q)
 138 e c b d
 139 > (front-delete-deque! q)
 140 (mcons
 141  #0=(mcons
 142      'c
 143      (mcons
 144       #1=(mcons 'b (mcons #2=(mcons 'd (mcons '() #1#)) #0#))
 145       (mcons 'e (mcons #0# '()))))
 146  #2#)
 147 > (print-deque q)
 148 c b d
 149 >
 150 |#