OOP in Scheme (serious example)

[Brian of ASTD-CP <brian@topaz.rutgers.edu>]

; This'll be my last submission on this topic, so I promise I won't
; be burning up the wires with any more.  I thought a serious 
; example would be of some interest, however, so here is a FIFO
; queue data type.  I'll be building classes for priority queues,
; heaps, splay trees, and assorted others, as well as a data flow
; executive.  Anyone interested further in this topic may feel
; free to e-mail me.  Again, sorry for the length of these sub-
; missions.  BCB.

;================================================================
;| Brian Beckman                  | brian@topaz.jpl.nasa.gov    |
;| Mail Stop 510-202              | (818) 397-9207              |
;| Jet Propulsion Laboratory      |                             |
;| Pasadena, CA 91109             | 3 July 1989                 |
;================================================================

;;; Adapted from Abelson & Sussman, Ch. 3, Pg 208 ff.
;;; Uses the ``methods'' OOP package.  This is an expanded,
;;; industrial-strength solution to Exercise 3.22 of A & S.

(define (new-queue . initial-list)
  
  (let (  (q (cons () ()))
          (dummy (if (not (null? initial-list))
                     (set! initial-list (car initial-list))))
          (supers ())  )
    
    (define (head) (car q))
    (define (tail) (cdr q))
    (define (set-head! item) (set-car! q item))
    (define (set-tail! item) (set-cdr! q item))
    
    (define (empty-queue?) (null? (head)))
    
    (define (front)
      (if (send self 'empty?)
          (error "FRONT called on empty queue")
          (car (head))))
    
    (define (insert-queue! item)
      (let ((elt (cons item ())))  ; could be (list item)
        (cond
         (  (send self 'empty?)
            (set-head! elt)
            (set-tail! elt)  
            self  )
         (  else
            (set-cdr! (tail) elt)
            (set-tail! elt)  
            self  ))))
    
    (define (insert-list! lyst)
      (cond
       (  (null? lyst)  self  )
       (  else
          (send self 'insert! (car lyst))
          (insert-list! (cdr lyst))  )))
    
    (define (remove-queue!)
      (cond
       (  (send self 'empty?)
          (error "REMOVE called on empty queue")  )
       (  else
          (set-head! (cdr (head)))  self)))
    
    (define (clear-queue!)
      (set! q (cons () ()))
      self)
    
    (define (print) (display (head)) (newline))
    
    (define (self msg)
      (cond
       (  (eq? msg 'insert!)       insert-queue!  )
       (  (eq? msg 'empty?)        empty-queue?   )
       (  (eq? msg 'remove!)       remove-queue!  )
       (  (eq? msg 'clear!)        clear-queue!   )
       (  (eq? msg 'front)         front  )
       (  (eq? msg 'print)         print  )
       (  (eq? msg 'list)          (lambda () (head))  )
       (  (eq? msg 'insert-list!)  insert-list!  )
       (  (search-supertypes supers msg)  )
       (  else  (make-error-method "Queue" msg)  )))
    
    (insert-list! initial-list)  ;;; returns ``self''
    
    ))
    ;;; end of new-queue

; Test suite for queues.

(define q (new-queue '(a b c d e)))

(send q 'print)

(send q 'list)

(send (send q 'remove!) 'print)

(send q 'empty?)

(send (send q 'clear!) 'empty?)

(send q 'print)

(define q (new-queue))

(send q 'empty?)