sicp-ex-3.23

<< Previous exercise (3.22) | Index | Next exercise (3.24) >>

wtative

 ;; Let 'decell' be a type of cell which contains references to two other cells (e.g. next and previous cells in queue) and a value. 
  
 ;; Although my 'deque' does contain a cycle, evaluating a deque itself does not force the interpreter into an infinite loop, because some evaluations are delayed which is a property of decell). 
 ;;----------------------------------------------------------------------;; 
 ;;; Deque ("double-ended queue"). 
 (define (make-deque) (cons '() '())) ; constructor 
  
 (define (empty-deque? deque) 
   ;; Even though an empty deque might contain 
   ;; a reference to an element we have "removed," we provide 
   ;; no access to it and consider the deque emptied. 
   (or (null? (front-dptr deque)) 
       (null? (rear-dptr deque)))) ; predicate 
  
 (define (front-deque deque) 
   (if (empty-deque? deque) 
       (error "FRONT called with an empty deque" deque) 
       (val-decell (front-dptr deque)))) 
 ;; see below for definition of a decell. 
 (define (rear-deque deque) 
   (if (empty-deque? deque) 
       (error "REAR called with an empty deque" deque) 
       (val-decell (rear-dptr deque)))) ; selectors  
  
 (define (set-first-deque! deque decell) 
   (set-front-dptr! deque decell) 
   (set-rear-dptr! deque decell)) 
 (define (front-insert-deque! deque item) 
   (let ((decell (make-decell '() item '()))) 
     (cond ((empty-deque? deque) 
            (set-first-deque! deque decell)) 
           (else 
            (connect-decell! decell (front-dptr deque)) 
            (set-front-dptr! deque decell))) 
     deque)) 
 (define (rear-insert-deque! deque item) 
   (let ((decell (make-decell '() item '()))) 
     (cond ((empty-deque? deque) 
            (set-first-deque! deque decell)) 
           (else 
            (connect-decell! (rear-dptr deque) decell) 
            (set-rear-dptr! deque decell))) 
     deque)) 
  
 (define (front-delete-deque! deque) 
   (cond ((empty-deque? deque) 
          (error "FRONT-DELETE called with an empty deque" deque)) 
         (else 
          (set-front-dptr! deque (right-decell (front-dptr deque))) 
          (if (not (empty-deque? deque)) 
              (set-left-decell! (front-dptr deque) '())) 
          deque))) 
 (define (rear-delete-deque! deque) 
   (cond ((empty-deque? deque) 
          (error "REAR-DELETE called with an empty deque" deque)) 
         (else 
          (set-rear-dptr! deque (left-decell (rear-dptr deque))) 
          (if (not (empty-deque? deque)) 
              (set-right-decell! (rear-dptr deque) '())) 
          deque))) ; mutators 
  
 (define (deque->list deque) 
   (define (iter decell) 
     (if (null? decell) 
         '() 
         (cons (val-decell decell) (iter (right-decell decell))))) 
   (if (empty-deque? deque) 
       '() 
       (iter (front-dptr deque)))) 
  
  
 ;; A dequeue is a pair of front and rear references to the same list, 
 ;; whose elements are decells. 
 (define (front-dptr deque) (car deque)) 
 (define (rear-dptr deque) (cdr deque)) 
 (define (set-front-dptr! deque decell) (set-car! deque decell)) 
 (define (set-rear-dptr! deque decell) (set-cdr! deque decell)) 
  
 ;; A decell is a cell, whose car is a pair of value and 
 ;; pointer to another decell (previous in queue). Whose cdr is a pointer 
 ;; to another decell (next in queue). 
 (define (make-decell left value right) 
   (cons (cons value left) right)) 
 (define (val-decell decell) (caar decell)) 
 (define (left-decell decell) 
   (if (not (null? (cdr (car decell)))) 
       ;; delay/force evaluation of this part 
       ;; prevents the interpreter from printing 
       ;; cycle of decells. 
       ((cdr (car decell))) 
       '())) 
 (define (right-decell decell) (cdr decell)) 
 (define (set-right-decell! decell right-decell) 
   (set-cdr! decell right-decell)) 
 (define (set-left-decell! decell left-decell) 
   (set-cdr! (car decell) 
             (lambda () left-decell))) 
  
 (define (connect-decell! l-decell r-decell) 
   (set-left-decell! r-decell l-decell) 
   (set-right-decell! l-decell r-decell)) 
  
 ;;; Test 
 (define deq (make-deque)) 
 (front-insert-deque! deq 'a) 
 (front-insert-deque! deq 'b) 
 (rear-insert-deque! deq 'z) 
 (rear-insert-deque! deq 'y) 
  
 (define (newline-display exp) 
   (newline) (display exp)) 
 (newline-display (deque->list deq)) 
 ;;Value: (b a z y) 
 (newline-display (front-deque deq)) 
 ;;Value: b 
 (front-delete-deque! deq) 
 (newline-display (front-deque deq)) 
 ;;Value: a 
 (rear-delete-deque! deq) 
 (newline-display (rear-deque deq)) 
 ;;Value: z

I've implemented the deque required in exercise 3.23 by first defining functions for doubly linked lists. I'm doing this as I'm learning Scheme so sorry for missing the idioms. 

 (define (make-dlink value prev next) 
   (cons (cons value prev) next)) 
 (define (value-dlink dlink) (car (car dlink))) 
 (define (next-dlink dlink) (cdr dlink)) 
 (define (prev-dlink dlink) (cdar dlink)) 
 (define (set-value-dlink! dlink v) (set-car! (car dlink) v)) 
 (define (set-next-dlink! dlink ref) (set-cdr! dlink ref)) 
 (define (set-prev-dlink! dlink ref) (set-cdr! (car dlink) ref)) 
  
 (define (push-prev-dlink! dlink value) 
   (and (not (null? (prev-dlink dlink))) 
        (error "PUSH-PREV! called on a middle link" dlink)) 
   (let ((new-pair (make-dlink value null dlink))) 
     (set-prev-dlink! dlink new-pair) 
     new-pair)) 
  
 (define (push-next-dlink! dlink value) 
   (and (not (null? (next-dlink dlink))) 
        (error "PUSH-NEXT! called on a middle link" dlink)) 
   (let ((new-pair (make-dlink value dlink null))) 
     (set-next-dlink! dlink new-pair) 
     new-pair)) 
  
 (define (make-deque) (cons '() '())) 
 (define (front-ptr deque) (car deque)) 
 (define (rear-ptr deque) (cdr deque)) 
 (define (set-front-ptr! deque v) (set-car! deque v)) 
 (define (set-rear-ptr! deque v) (set-cdr! deque v)) 
  
 (define (empty-deque? deque) (null? (front-ptr deque))) 
  
 (define (front-deque deque) 
   (if (empty-deque? deque) 
       (error "FRONT called with an empty deque" deque) 
       (car (front-ptr deque)))) 
  
 (define (rear-deque deque) 
   (if (empty-deque? deque) 
       (error "REAR called with an empty deque" deque) 
       (car (rear-ptr deque)))) 
  
 (define *front* (lambda (x y) x)) 
 (define *rear* (lambda (x y) y)) 
  
 (define (insert-deque! side deque item) 
   (cond ((empty-deque? deque) 
          (let ((new-pair (make-dlink item null null))) 
            (set-front-ptr! deque new-pair) 
            (set-rear-ptr! deque new-pair))) 
         (else 
          (let ((push-ref-dlink! (side push-prev-dlink! push-next-dlink!)) 
                (ptr (side front-ptr rear-ptr)) 
                (set-ptr! (side set-front-ptr! set-rear-ptr!))) 
            (let ((new-pair (push-ref-dlink! (ptr deque) item))) 
              (set-ptr! deque new-pair))))) 
   deque) 
  
 (define (front-insert-deque! deque item) 
   (insert-deque! *front* deque item)) 
  
 (define (rear-insert-deque! deque item) 
   (insert-deque! *rear* deque item)) 
  
 (define (delete-deque! side deque) 
   (and (empty-deque? deque) 
        (error "DELETE! called with an empty deque" deque)) 
   (let ((ptr (side front-ptr rear-ptr)) 
         (set-ptr! (side set-front-ptr! set-rear-ptr!)) 
         (ref-dlink (side next-dlink prev-dlink)) 
         (set-ref-new-dlink! (side set-prev-dlink! set-next-dlink!)) 
         (set-ref-popped-dlink! (side set-next-dlink! set-prev-dlink!))) 
     (let* ((pop (ptr deque)) 
            (new-tip (ref-dlink pop))) 
       (cond ((pair? new-tip) 
              (set-ref-new-dlink! new-tip null) 
              (set-ptr! deque new-tip)) 
             (else 
              (set-front-ptr! deque null) 
              (set-rear-ptr! deque null))) 
       (set-ref-popped-dlink! pop null) 
       (value-dlink pop)))) 
  
 (define (front-delete-deque! deque) 
   (delete-deque! *front* deque)) 
  
 (define (rear-delete-deque! deque) 
   (delete-deque! *rear* deque))

gws says: a more compact solution, including a print-deque function to return a list representation of the deque 

 (define (make-deque) (cons nil nil)) 
 (define (front-ptr deque) (car deque)) 
 (define (rear-ptr deque) (cdr deque)) 
 (define (empty-deque? deque) (null? (front-ptr deque))) 
 (define (set-front! deque item) (set-car! deque item)) 
 (define (set-rear! deque item) (set-cdr! deque item)) 
  
 (define (get-item deque end) 
   (if (empty-deque? deque) 
     (error "Trying to retrieve item from empty deque" deque) 
     (caar (end deque)))) 
  
 (define (insert-deque! deque item end) 
   (let ((new-pair (cons (cons item nil) nil))) 
     (cond ((empty-deque? deque) 
            (set-front! deque new-pair) 
            (set-rear! deque new-pair)) 
           ((eq? end 'front) 
            (set-cdr! new-pair (front-ptr deque)) 
            (set-cdr! (car (front-ptr deque)) new-pair) 
            (set-front! deque new-pair)) 
           (else (set-cdr! (rear-ptr deque) new-pair) 
                 (set-cdr! (car new-pair) (rear-ptr deque)) 
                 (set-rear! deque new-pair))))) 
  
 (define (front-delete-deque deque) 
   (cond ((empty-deque? deque) (error "Cannot delete from empty deque" deque)) 
         (else (set-front! deque (cdr (front-ptr deque))) 
               (or (empty-deque? deque) (set-cdr! (car (front-ptr deque)) nil))))) 
  
 (define (rear-delete-deque deque) 
   (cond ((empty-deque? deque) (error "Cannot delete from empty deque" deque)) 
         (else (set-rear! deque (cdar (rear-ptr deque))) 
               (if (null? (rear-ptr deque)) (set-front! deque nil) 
                 (set-cdr! (rear-ptr deque) nil))))) 
  
 (define (front-insert-deque! deque item) (insert-deque! deque item 'front)) 
 (define (rear-insert-deque! deque item) (insert-deque! deque item 'rear)) 
 (define (front-deque deque) (get-item deque front-ptr)) 
 (define (rear-deque deque) (get-item deque rear-ptr)) 
  
 (define (print-deque d) 
   (define (iter res _d) 
     (if (or (null? _d) (empty-deque? _d)) res 
       (iter (append res (list (caaar _d))) (cons (cdar _d) (cdr d))))) 
   (iter nil d))

danhuynh

Kinda the same as above but using internal variables instead of pair 

  
 ;;; We gonna make a two way structure like this diagram 
 ;;;                 +-------------------+ 
 ;;; +---------------|------+            | 
 ;;; +->[[a|/] | -]--+->[[b|'] | -]->[[c|'] |/] 
 ;;; 
 ;;; Which will display this in the repl of guile scheme 
 ;;; ((a) (b . #-2#) (c . #-2#)) 
  
 (define (make-deque) 
   (let ((front-ptr '()) 
         (rear-ptr '())) 
     (define (dispatch m) 
       (cond ((equal? m 'empty-deque?) 
              (null? front-ptr)) 
             ((equal? m 'rear-ptr) 
              rear-ptr) 
             ((equal? m 'front-ptr) 
              front-ptr) 
             ((equal? m 'set-front-ptr!) 
              (lambda (item) (set! front-ptr item))) 
             ((equal? m 'set-rear-ptr!) 
              (lambda (item) (set! rear-ptr item))))) 
     dispatch)) 
  
 (define (empty-deque? deque) 
   (deque 'empty-deque?)) 
 (define (front-ptr deque) 
   (deque 'front-ptr)) 
 (define (rear-ptr deque) 
   (deque 'rear-ptr)) 
 (define (front-deque deque) 
   (if (empty-deque? deque) 
       (error "FRONT called with an empty deque" deque) 
       (caar (front-ptr deque)))) 
 (define (rear-deque deque) 
   (if (empty-deque? deque) 
       (error "REAR called with an empty deque" deque) 
       (caar (rear-ptr deque)))) 
 (define (set-front-ptr! deque item) 
   ((deque 'set-front-ptr!) item)) 
 (define (set-rear-ptr! deque item) 
   ((deque 'set-rear-ptr!) item)) 
  
 (define (front-insert-deque! deque item) 
   (let ((newlist (cons (cons item '()) '()))) 
     (if (empty-deque? deque) 
         (begin 
           (set-front-ptr! deque newlist) 
           (set-rear-ptr! deque newlist) 
           deque) 
         (begin 
           (set-cdr! (car (front-ptr deque)) newlist) 
           (set-cdr! newlist (front-ptr deque)) 
           (set-front-ptr! deque newlist) 
           deque)))) 
  
 (define (rear-insert-deque! deque item) 
   (let ((newlist (cons (cons item '()) '()))) 
     (if (empty-deque? deque) 
         (begin 
           (set-front-ptr! deque newlist) 
           (set-rear-ptr! deque newlist) 
           deque) 
         (begin 
           (set-cdr! (car newlist) (rear-ptr deque)) 
           (set-cdr! (rear-ptr deque) newlist) 
           (set-rear-ptr! deque newlist) 
           deque)))) 
  
 (define (front-delete-deque! deque) 
   (cond ((empty-deque? deque) 
          (error "DELETE! called with an empty deque" deque)) 
         ((null? (cdar (rear-ptr deque))) 
          (set-front-ptr! deque '())) 
         (else 
          (set-front-ptr! deque (cdr (front-ptr deque))) 
          (set-cdr! (car (front-ptr deque)) '()) 
          deque))) 
  
 (define (rear-delete-deque! deque) 
   (cond ((empty-deque? deque) 
          (error "DELETE! called with an empty deque" deque)) 
         ((null? (cdar (rear-ptr deque))) 
          (set-front-ptr! deque '())) 
         (else 
          (set-rear-ptr! deque (cdar (rear-ptr deque))) 
          (set-cdr! (rear-ptr deque) '())))) 
  
 (define (print-deque deque) 
   (display (map car 
                 (front-ptr deque))) (newline))

yooka

Use One-layer list instead of Two-layer list above and use inner define style 

 (define (make-deque) 
   (let ((front-ptr '()) 
         (rear-ptr '())) 
     ;;;sub process 
     (define (front-insert-deque! item) 
       (let ((new-pair (list item '() '()))) 
         (cond ((null? front-ptr) 
                (set! front-ptr new-pair) 
                (set! rear-ptr new-pair)) 
               (else 
                (set-cdr! (cdr new-pair) front-ptr) 
                (set-car! (cdr front-ptr) new-pair) 
                (set! front-ptr new-pair))) 
         front-ptr)) 
     (define (rear-insert-deque! item) 
       (let ((new-pair (list item '() '()))) 
         (cond ((null? front-ptr) 
                (set! front-ptr new-pair) 
                (set! rear-ptr new-pair)) 
               (else 
                (set-car! (cdr new-pair) rear-ptr) 
                (set-cdr! (cdr rear-ptr) new-pair) 
                (set! rear-ptr new-pair))) 
         front-ptr)) 
     (define (front-delete-deque!) 
       (set! front-ptr (cddr front-ptr)) 
       (set-car! (cdr front-ptr) '()) 
       front-ptr) 
     (define (rear-delete-deque!) 
       (set! rear-ptr (cadr rear-ptr)) 
       (set-cdr! (cdr rear-ptr) '()) 
       front-ptr) 
     (define (print) 
       (define (iter x result) 
                (if (null? (cddr x)) 
                    (append result (cons (car x) '())) 
                    (iter (cddr x) (append result (cons (car x) '()))))) 
       (iter front-ptr '())) 
      
     (define (dispatch m) 
       (cond ((eq? m 'front-ptr) front-ptr) 
             ((eq? m 'rear-ptr) rear-ptr) 
             ((eq? m 'print) print) 
             ((eq? m 'empty-queue?) (null? front-ptr)) 
             ((eq? m 'front-delete-deque!) front-delete-deque!) 
             ((eq? m 'rear-delete-deque!) rear-delete-deque!) 
             ((eq? m 'rear-insert-deque!) rear-insert-deque!) 
             ((eq? m 'front-insert-deque!) front-insert-deque!) 
             (else 
              (display "Bad operate")))) 
     dispatch)) 
 (define mq (make-deque)) 
 ((mq 'rear-insert-deque!) 'a) 
 ((mq 'rear-insert-deque!) 'b) 
 ((mq 'rear-insert-deque!) 'c) 
 ((mq 'front-insert-deque!) 'd) 
 ((mq 'front-insert-deque!) 'e) 
 ((mq 'front-insert-deque!) 'f) 
 ((mq 'front-delete-deque!)) 
 ((mq 'rear-delete-deque!)) 
 ((mq 'print))


GP

Since we have learnt in Chap 2. about data abstraction and abstraction layers, it makes more sense here to build one more abstraction layer by adding properly designed constructors and selectors. The solution will be more modularized and extendable. The code is also a bit more readable in my opinion. 

 ; using local variables and message passing instead of defining function under global environment 
  
 (define (make-deque) 
   (let ((front-ptr '()) 
         (rear-ptr '())) 
  
     ; one more abstraction barrier allows flexible and extendable implementation for both lower and higher level methods 
     ; one example here is modifing lower level implementation of node structure dose not  the methods for deque 
     ; also, higher level modification (modifying deque methods) will not influence lower level implementation 
  
     ; lower level constructor and selectors 
     ; each has two different implementations. (higher level methods do not need to be changed)  
     (define (make-node item) 
       (cons (cons item '()) '())) 
     (define (make-node1 item) 
       (cons item (cons '() '()))) 
  
     (define (node-item node) 
       (caar node)) 
     (define (node-item1 node) 
       (car node)) 
  
     (define (next-node node) 
       (cdr node)) 
     (define (next-node1 node) 
       (cddr node)) 
  
     (define (prev-node node) 
       (cdar node)) 
     (define (prev-node1 node) 
       (cadr node)) 
     (define (set-prev-node! node prevnode) 
       (set-cdr! (car node) prevnode)) 
     (define (set-prev-node!1 node prevnode) 
       (set-car! (cdr node) prevnode)) 
     (define (set-next-node! node nextnode) 
       (set-cdr! node nextnode)) 
     (define (set-next-node!1 node nextnode) 
       (set-cdr! (cdr node) nextnode)) 
  
     (define (set-front-ptr! item) 
       (set! front-ptr item)) 
     (define (set-rear-ptr! item) 
       (set! rear-ptr item)) 
  
  
     ; higher level methods for deque 
     ; constructors and selectors 
     (define (empty-deque?) (null? front-ptr)) 
      
     (define (front-deque) 
       (if (empty-deque?) 
           (error "FRONT called with an empty deque") 
           (node-item front-ptr))) 
  
     (define (front-insert-deque! item) 
       (let ((new-node (make-node item))) 
         (cond ((empty-deque?) 
                (set-front-ptr! new-node) 
                (set-rear-ptr! new-node)) 
               (else 
                (set-prev-node! front-ptr new-node) 
                (set-next-node! new-node front-ptr) 
                (set-front-ptr! new-node))))) 
  
     ; methods to modify deques 
     (define (rear-insert-deque! item) 
       (let ((new-node (make-node item))) 
         (cond ((empty-deque?) 
                (set-front-ptr! new-node) 
                (set-rear-ptr! new-node)) 
               (else 
                (set-prev-node! new-node rear-ptr) 
                (set-next-node! rear-ptr new-node) 
                (set-rear-ptr! new-node))))) 
  
     (define (front-delete-deque!) 
       (cond ((empty-deque?) 
              (error "DELETE! called with an empty deque")) 
             (else 
              (set-front-ptr! (next-node front-ptr)) 
              (if (null? front-ptr) 
                  (set-rear-ptr! '()) 
                  (set-prev-node! front-ptr '()))))) 
  
     (define (rear-delete-deque!) 
       (cond ((empty-deque?) 
              (error "DELETE! called with an empty deque")) 
             (else 
              (set-rear-ptr! (prev-node rear-ptr)) 
              (if (null? rear-ptr) 
                  (set-front-ptr! '()) 
                  (set-next-node! rear-ptr '()))))) 
  
     (define (print-deque) 
       (define (print-node node) 
         (cond ((null? node) nil) 
               (else (cons (node-item node) (print-node (next-node node)))))) 
       (display (print-node front-ptr)) 
       (newline)) 
  
     (define (dispatch m) 
       (cond ((eq? m 'front-deque) front-deque) 
             ((eq? m 'empty-deque?) empty-deque?) 
             ((eq? m 'front-insert-deque!) front-insert-deque!) 
             ((eq? m 'rear-insert-deque!) rear-insert-deque!) 
             ((eq? m 'front-delete-deque!) front-delete-deque!) 
             ((eq? m 'rear-delete-deque!) rear-delete-deque!) 
             ((eq? m 'print-deque) print-deque))) 
     dispatch)) 
  
 ;define global methods with message passing 
 (define (front-deque deque) ((deque 'front-deque))) 
 (define (empty-deque? deque) ((deque 'empty-deque?))) 
 (define (front-insert-deque! deque item) ((deque 'front-insert-deque!) item)) 
 (define (rear-insert-deque! deque item) ((deque 'rear-insert-deque!) item)) 
 (define (front-delete-deque! deque) ((deque 'front-delete-deque!))) 
 (define (rear-delete-deque! deque) ((deque 'rear-delete-deque!))) 
 (define (print-deque deque) ((deque 'print-deque))) 
  
 ;; ---- TESTING CODE ----  
 ;test deque constructor and selectors 
 (define d (make-deque)) 
 (empty-deque? d) 
 (print-deque d) 
  
 ; testing front insert  
 (newline) 
 (display "---- testing front insert ----") 
 (newline) 
 (front-insert-deque! d 'a) 
 (print-deque d) 
 (front-insert-deque! d 'b) 
 (print-deque d) 
 (front-insert-deque! d 'c) 
 (print-deque d) 
  
 ; testing front delete 
 (newline) 
 (display "---- testing front delete ----") 
 (newline) 
 (front-delete-deque! d) 
 (print-deque d) 
 (front-delete-deque! d) 
 (print-deque d) 
 (front-delete-deque! d) 
 (print-deque d) 
  
 ; testing rear insert  
 (newline) 
 (display "---- testing rear insert ----") 
 (newline) 
 (rear-insert-deque! d 'a) 
 (print-deque d) 
 (rear-insert-deque! d 'b) 
 (print-deque d) 
 (rear-insert-deque! d 'c) 
 (print-deque d) 
  
 ; testing rear delete 
 (newline) 
 (display "---- testing rear delete ----") 
 (newline) 
 (rear-delete-deque! d) 
 (print-deque d) 
 (rear-delete-deque! d) 
 (print-deque d) 
 (rear-delete-deque! d) 
 (print-deque d) 
  
 ; testing front-insert and rear delete 
 (newline) 
 (display "---- testing front-insert and rear delete ----") 
 (newline) 
 (front-insert-deque! d 'a) 
 (print-deque d) 
 (rear-delete-deque! d) 
 (print-deque d)

tandroide

My solution uses a list called rear-list to store the pairs in reversed order (note that it is not a reversed queue because the pairs are not linked, just belong to this list as elements). When an item is add either front or rear the rear-list also grows (front for rear-add and rear for front-add). When we have to remove from rear we take the car of rear-list and know what pair is "before" our rear-ptr, this pair's cdr is our rear-ptr before the delete operation. It works on O(1) time, but the space is not efficient because every time we add an element to the deque each element of the rear-list (the pairs of the deque) also grow by one element. EDIT: my solution has a bug, it's that when we remove front the front in the deque we should also remove the last element of the rear-list, but I can not think of a way in which this could be done in O(1) time. 

 (define (make-deque) 
   (let ((front-ptr '()) 
         (rear-ptr '()) 
         (rear-list '())) 
     (define (empty-deque?) 
       (or (null? front-ptr) (null? rear-ptr))) 
     (define (front-insert-deque! item) 
       (let  ((new-pair (cons item '())))  
         (cond ( (empty-deque?) 
                 (set! front-ptr new-pair) 
                 (set! rear-ptr new-pair)) 
               (else  
                 (set-cdr! new-pair front-ptr) 
                 (set! front-ptr new-pair) 
                 (cond ((null? rear-list) 
                        (set! rear-list  
                             (append (list new-pair)  
                             rear-list))) 
                       (else 
                         (set! rear-list 
                           (append rear-list (list new-pair))))))))) 
     (define (rear-insert-deque! item) 
       (let ((new-pair (cons item '()))) 
         (cond ( (empty-deque?) 
                 (set! front-ptr new-pair) 
                 (set! rear-ptr new-pair)) 
               (else 
                 (set-cdr! rear-ptr new-pair) 
                 (set! rear-list (append (list rear-ptr) rear-list)) 
                 (set! rear-ptr new-pair))))) 
     (define (front-delete-deque!) 
       (cond ( (null? front-ptr) (set! front-ptr '())) 
             ( (null? (cdr front-ptr)) 
               (set! front-ptr '()) 
               (set! rear-ptr '())) 
             (else 
               (set! front-ptr (cdr front-ptr))))) 
     (define (rear-delete-deque!) 
       (cond ( (null? rear-ptr) (set! rear-ptr '())) 
             ( (null? rear-list) 
               (set! rear-ptr '()) 
               (set! front-ptr '())) 
             (else 
               (set-cdr! (car rear-list) '()) 
               (set! rear-ptr (car rear-list)) 
               (set! rear-list (cdr rear-list)) 
               ))) 
     (define (print-deque) 
       (display front-ptr)) 
       (newline) 
     (define (dispatch m) 
       (cond ((eq? m 'front-ptr) front-ptr) 
             ((eq? m 'rear-ptr) rear-ptr) 
             ((eq? m 'front-insert-deque!) front-insert-deque!) 
             ((eq? m 'rear-insert-deque!) rear-insert-deque!) 
             ((eq? m 'front-delete-deque!) (front-delete-deque!)) 
             ((eq? m 'rear-delete-deque!) (rear-delete-deque!)) 
             ((eq? m 'empty-deque?) (empty-deque?)) 
             ((eq? m 'print-deque) (print-deque)))) 
     dispatch))


master

Omitting all constructors and selectors previously defined, they were left unchanged. Maybe it's because I didn't think about the problem hard enough before getting started, but I implemented all of the deque operations using a standard list representation until I got to rear-delete-deque! which is of course impossible to implement that way (at least if it needs to take constant time). So I had to rewrite everything using a new representation and for that reason it may be a little bit more ad-hoc than the other solutions here but OTOH it is exactly as much mechanism as is needed, no more no less. The representation I went for is something akin to a doubly linked list, where the cars are all nodes which contain the symbol at that node plus a linked list which goes in the reverse direction (which I call cir (contents of increment register) to keep with the terminology). It is an extension of the original list, i.e. the cirs are pointers to previous nodes, so there is no need to keep a reversed copy of the original list around. 

 (define (make-node cir item) 
   (cons cir item)) 
  
 (define (node-cir node) 
   (car node)) 
  
 (define (node-item node) 
   (cdr node)) 
  
 (define (front-insert-deque! deque item) 
   (cond ((empty-deque? deque) 
          (let ((new-node (make-node '() item))) 
            (let ((new-pair (cons new-node '()))) 
              (set-front-ptr! deque new-pair) 
              (set-rear-ptr! deque new-pair) 
              (print-deque deque)))) 
         (else 
          (let ((new-node (make-node '() item))) 
            (let ((new-pair (cons new-node '()))) 
              (set-car! (front-deque deque) new-node) 
              (set-cdr! new-pair (front-ptr deque)) 
              (set-front-ptr! deque new-pair) 
              (print-deque deque)))))) 
  
 (define (rear-insert-deque! deque item) 
   (cond ((empty-deque? deque) 
          (let ((new-node (make-node '() item))) 
            (let ((new-pair (cons new-node '()))) 
              (set-front-ptr! deque new-pair) 
              (set-rear-ptr! deque new-pair) 
              (print-deque deque)))) 
         (else 
          (let ((new-node (make-node '() item))) 
            (let ((new-pair (cons new-node '()))) 
              (set-car! new-node (rear-deque deque)) 
              (set-cdr! (rear-ptr deque) new-pair) 
              (set-rear-ptr! deque new-pair) 
              (print-deque deque)))))) 
  
 (define (front-delete-deque! deque) 
   (cond ((empty-deque? deque) 
          (error "DELETE! called with an empty deque" deque)) 
         (else (set-front-ptr! deque (cdr (front-ptr deque))) 
               (print-deque deque)))) 
  
 (define (rear-delete-deque! deque) 
   (cond ((empty-deque? deque) 
          (error "DELETE! called with an empty deque" deque)) 
         (else (set-rear-ptr! deque (node-cir (rear-ptr deque))) 
               (set-cdr! (rear-ptr deque) '()) 
               (print-deque deque)))) 
  
 (define (print-deque deque) 
   (let ((items (front-ptr deque))) 
     (define (helper rest) 
       (if (null? rest) 
           (newline) 
           (begin (if (not (null? (node-item (car rest)))) 
                      (display (node-item (car rest)))) 
                  (display " ") 
                  (helper (cdr rest))))) 
     (if (cycle? deque) 
         (error "Deque contains a cycle, unable to print" deque) 
         (begin (helper items) 
                (newline)))))

x3v

Tried to make as few changes to the message-passing style queue structure as possible. Key change is every new item contains 3 elements now: (value, leftptr, rightptr), as opposed to (value, rightptr). 

  
 (define (make-deque) 
   (let ((front-ptr '()) 
         (rear-ptr '())) 
     (define (set-front-ptr! item) (set! front-ptr item)) 
     (define (set-rear-ptr! item) (set! rear-ptr item)) 
     (define (empty-deque?) (null? front-ptr)) 
     (define (front-deque) 
       (if (empty-deque?) (error "empty queue") (car front-ptr))) 
     (define (rear-deque) 
       (if (empty-deque?) (error "empty deque") (car rear-ptr))) 
     (define (front-insert-deque! item) 
       (let ((new-pair (list item '() '()))) 
         (cond ((empty-deque?) 
                (set-front-ptr! new-pair) 
                (set-rear-ptr! new-pair)) 
               (else (set-car! (cddr new-pair) front-ptr) 
                     (set-car! (cdr front-ptr) new-pair) 
                     (set-front-ptr! new-pair)))) 
       front-ptr) 
     (define (rear-insert-deque! item) 
       (let ((new-pair (list item '() '()))) 
         (cond ((empty-deque?) 
                (set-front-ptr! new-pair) 
                (set-rear-ptr! new-pair)) 
               (else (set-car! (cdr new-pair) rear-ptr) 
                     (set-car! (cddr rear-ptr) new-pair) 
                     (set-rear-ptr! new-pair)))) 
       front-ptr) 
     (define (front-delete-deque!) 
       (cond ((empty-deque?) (error "empty deque")) 
             ((eq? front-ptr rear-ptr) 
              (set! front-ptr '()) 
              (set! rear-ptr '())) 
             (else (set-front-ptr! (caddr front-ptr)) 
                   (set-car! (cdr front-ptr) '()))) 
       front-ptr) 
     (define (rear-delete-deque!) 
       (cond ((empty-deque?) (error "empty deque")) 
             ((eq? front-ptr rear-ptr) 
              (set! rear-ptr '()) 
              (set! front-ptr '())) 
             (else (set-rear-ptr! (cadr rear-ptr)) 
                   (set-car! (cddr rear-ptr) '()))) 
       front-ptr) 
     (define (print) 
       (define (iter p) 
         (if (null? p) 
             '() 
             (cons (car p) (iter (caddr p))))) 
       (iter front-ptr)) 
     (define (dispatch m) 
       (cond ((eq? m 'front-deque) (front-deque)) 
             ((eq? m 'rear-deque) (rear-deque)) 
             ((eq? m 'empty-deque?) (empty-deque?)) 
             ((eq? m 'front-insert-deque!) front-insert-deque!) 
             ((eq? m 'rear-insert-deque!) rear-insert-deque!) 
             ((eq? m 'front-delete-deque!) (front-delete-deque!)) 
             ((eq? m 'rear-delete-deque!) (rear-delete-deque!)) 
             ((eq? m 'print) (print)) 
             (else (error "incorrect usage" m)))) 
     dispatch)) 
  
 (define (front-deque dq) 
   (dq 'front-deque)) 
 (define (rear-deque dq) 
   (dq 'rear-deque)) 
 (define (empty-deque? dq) 
   (dq 'empty-deque?)) 
 (define (front-insert-deque! dq item) 
   ((dq 'front-insert-deque!) item)) 
 (define (rear-insert-deque! dq item) 
   ((dq 'rear-insert-deque!) item)) 
 (define (rear-delete-deque! dq) 
   (dq 'rear-delete-deque!) 
   (print-dq dq)) 
 (define (front-delete-deque! dq) 
   (dq 'front-delete-deque!) 
   (print-dq dq)) 
 (define (print-dq dq) 
   (dq 'print))

roy-tobin

Nicely done. Compact with a lovely pattern of indentation. And no pollution of the global environment. This implementation passes a 1.3k transaction torture test I created. Others on this page (Feb 2023) do not. My own deque solution is at the link, nothing new, but fully tested.



tch

Just use a double direction linked list like everyone else. 

 ; deque: double ended queue, (front-node. rear-node) 
 (define (make-deque) (cons nil nil)) 
 (define (empty-deque? q) (null? (front-node-deque q))) 
 (define (front-deque q) (value-node (front-node-deque q))) 
 (define (rear-deque q) (value-node (rear-node-deque q))) 
  
 ; auxiliary procedures 
 (define (deque-only-one-element? q) (eq? (front-node-deque q) (rear-node-deque q))) 
 (define (front-node-deque q) (car q)) 
 (define (rear-node-deque q) (cdr q)) 
 (define (set-deque-front! q value) (set-car! q value)) 
 (define (set-deque-rear! q value) (set-cdr! q value)) 
  
 ; node of deque (just like a double-direction linked list) 
 (define (make-node prev value next) (list 'node prev value next)) 
 (define (prev-node node) (cadr node)) 
 (define (value-node node) (caddr node)) 
 (define (next-node node) (cadddr node)) 
 (define (set-node-prev! node value) (set-car! (cdr node) value)) 
 (define (set-node-next! node value) (set-car! (cdddr node) value)) 
  
 ; use a list of node to construct deque 
 ; all return values are unspecified 
 (define (front-insert-deque! q value) 
     (let ((new-node (make-node nil value nil))) 
         (cond ((empty-deque? q) (set-deque-front! q new-node) 
                                 (set-deque-rear! q new-node)) 
               (else (set-node-next! new-node (front-node-deque q)) 
                     (set-node-prev! (front-node-deque q) new-node) 
                     (set-deque-front! q new-node)) 
         ) 
     ) 
 ) 
 (define (rear-insert-deque! q value) 
     (let ((new-node (make-node nil value nil))) 
         (cond ((empty-deque? q) (set-deque-front! q new-node) 
                                 (set-deque-rear! q new-node)) 
               (else (set-node-next! (rear-node-deque q) new-node) 
                     (set-node-prev! new-node (rear-node-deque q)) 
                     (set-deque-rear! q new-node)) 
         ) 
     ) 
 ) 
 (define (front-delete-deque! q) 
     (cond ((empty-deque? q) (error "Delete front from an empty deque.")) 
           ((deque-only-one-element? q) (set-deque-front! q nil) 
                                        (set-deque-rear! q nil)) ; only one element 
           (else (set-deque-front! q (next-node (front-node-deque q))) 
                 (set-node-prev! (front-node-deque q) nil)) 
     ) 
 ) 
 (define (rear-delete-deque! q) 
     (cond ((empty-deque? q) (error "Delete rear from an empty deque.")) 
           ((deque-only-one-element? q) (set-deque-front! q nil) 
                                        (set-deque-rear! q nil)) ; only one element 
           (else (set-deque-rear! q (prev-node (rear-node-deque q))) 
                 (set-node-next! (rear-node-deque q) nil)) 
     ) 
 ) 
 (define (print-deque q) 
     (define (iter node) 
         (if (not (null? node)) 
             (begin (display (value-node node)) 
                    (display " ") 
                    (iter (next-node node)) 
             ) 
         ) 
     ) 
     (display "#deque front ... rear : ") 
     (iter (front-node-deque q)) 
     (newline) 
 ) 
  
 ; test 
 (define q (make-deque)) 
 (print-deque q) 
 (front-insert-deque! q 1) 
 (front-insert-deque! q 2) 
 (front-insert-deque! q 3) 
 (rear-insert-deque! q 10) 
 (rear-insert-deque! q 100) 
 (rear-insert-deque! q 1000) 
 (print-deque q) 
  
 (front-deque q) 
 (rear-deque q) 
  
 (front-delete-deque! q) 
 (rear-delete-deque! q) 
 (rear-delete-deque! q) 
 (print-deque q)

bro-chenzox

  
  
 (define (make-deque) 
   (let ((front-node '()) ; () ; (() a ()) ; (() a (() b ())) ; 
         (rear-node '())) ; () ; (() a ()) ; (() a (() c ())) ; ((() a (() c ())) c ()) 
     (define (empty-deque?) (null? front-node)) 
     (define (front-deque) 
       (if (empty-deque?) 
           (error "FRONT-DEQUE was called in an empty deque") 
           (node-value front-node))) 
     (define (rear-deque) 
       (if (empty-deque?) 
           (error "REAR-DEQUE was called in an empty deque") 
           (node-value rear-node))) 
  
     ; auxiliary procedures 
     (define (set-front-node! item) (set! front-node item)) 
     (define (set-rear-node! item) (set! rear-node item)) 
     (define (single-item-deque?) (eq? front-node rear-node)) 
  
     ; node structure 
     (define (make-node prev value next) (list prev value next)) 
     (define (node-prev node) (car node)) 
     (define (node-value node) 
       (if (null? node) 
           '() 
           (cadr node))) 
     (define (node-next node) (caddr node)) 
     (define (set-node-prev! node item) (set-car! node item)) 
     (define (set-node-next! node item) (set-car! (cddr node) item)) 
      
     (define (insert-deque! side) 
       (lambda (item) 
         (let ((new-node (make-node '() item '()))) ; (() a ()) ; (() b ()) ; (() c ()) ; ((() a (() c ())) c ()) ; 
           (cond ((empty-deque?) 
                  (set-front-node! new-node) 
                  (set-rear-node! new-node)) 
                 (else 
                  (cond ((eq? side 'front) 
                         (set-node-next! new-node front-node) 
                         (set-front-node! new-node)) 
                         ((eq? side 'rear) 
                          (set-node-next! rear-node new-node) 
                          (set-node-prev! new-node rear-node) 
                          (set-rear-node! new-node)))))) 
         (cons (list (node-value front-node)) (list (node-value rear-node))))) 
  
     (define (delete-deque! side) 
       (cond ((empty-deque?) 
              (error "DELETE-DEQUE! called with an empty deque")) 
             ((single-item-deque?) 
              (set-front-node! '()) 
              (set-rear-node! '()) 
              'empty-dq) 
             (else 
              (cond ((eq? side 'front) 
                     (set-front-node! (node-next front-node)) 
                     (set-node-prev! front-node '())) 
                    ((eq? side 'rear) 
                     (set-rear-node! (node-prev rear-node)) 
                     (set-node-next! rear-node '()))) 
              (cons (list (node-value front-node)) (list (node-value rear-node)))))) 
      
   (define (front-insert-deque!) (insert-deque! 'front)) 
   (define (rear-insert-deque!) (insert-deque! 'rear)) 
   (define (front-delete-deque!) (delete-deque! 'front)) 
   (define (rear-delete-deque!) (delete-deque! 'rear))   
      
   (define (dispatch m) 
     (cond ((eq? m 'front) (front-deque)) 
           ((eq? m 'rear) (rear-deque)) 
           ((eq? m 'front-insert) (front-insert-deque!)) 
           ((eq? m 'rear-insert) (rear-insert-deque!)) 
           ((eq? m 'front-delete) (front-delete-deque!)) 
           ((eq? m 'rear-delete) (rear-delete-deque!)))) 
   dispatch)) 
  
 (define dq (make-deque)) 
 ((dq 'front-insert) 'a) 
 ((dq 'front-insert) 'b) 
 ((dq 'rear-insert) 'c) 
  
 ;(dq 'front-delete) 
 ;(dq 'front) 
 ;(dq 'rear) 
 ;(dq 'rear-delete) 
 ;(dq 'rear-delete) 
 ;((dq 'rear-insert) 'a)

<< Previous exercise (3.22) | Index | Next exercise (3.24) >>

Last modified : 2023-02-21 15:30:09
WiLiKi 0.5-tekili-7 running on Gauche 0.9