aop-r7rs/aop/12.body.scm

(define (for-effect-only item-ignored)
  "unspecified value")

(define invalid-method-name-indicator "unknown")

(define (box-maker init-value)
  (let ((contents init-value))
    (lambda msg
      (case (first msg)
        ((type) "box")
        ((show) contents)
        ((update!)
         (for-effect-only (set! contents (second msg))))
        ((swap!)
         (let ((ans contents))
           (set! contents (second msg))
           ans))
        ((reset!)
         (for-effect-only (set! contents init-value)))
        (else (delegate base-object msg))))))

(define (delegate obj msg)
  (apply obj msg))

(define base-object
  (lambda msg
    (case (first msg)
      ((type) "base-object")
      (else invalid-method-name-indicator))))

(define (send . args)
  (let* ((object (car args))
         (message (cdr args))
         (try (apply object message)))
    (if (eq? invalid-method-name-indicator try)
        (error "Bad method name:" (car message)
               "sent to object of"
               (object 'type)
               "type.")
        try)))

(define (counter-maker init-value unary-proc)
  (let ((total (box-maker init-value)))
    (lambda msg
      (case (first msg)
        ((type) "counter")
        ((update!)
         (let ((result (unary-proc (send total 'show))))
           (send total 'update! result)))
        ((show reset!) (delegate total msg))
        (else (delegate base-object msg))))))

(define (accumulator-maker init-value binary-proc)
  (let ((total (box-maker init-value)))
    (lambda msg
      (case (first msg)
        ((type "accumulator"))
        ((update!)
         (send total 'update!
               (binary-proc (send total 'show)
                            (second msg))))
        ((show reset!) (delegate total msg))
        (else (delegate base-object msg))))))

(define (gauge-maker init-value unary-proc-up unary-proc-down)
  (let ((total (box-maker init-value)))
    (lambda msg
      (case (first msg)
        ((type) "gauge")
        ((up!)
         (send total 'update!
               (unary-proc-up (send total 'show))))
        ((down!)
         (send total 'update!
               (unary-proc-down (send total 'show))))
        ((show reset!) (delegate total msg))
        (else (delegate base-object msg))))))

(define (stack-maker)
  (let ((stk '()))
    (lambda msg
      (case (first msg)
        ((type) "stack")
        ((empty?) (null? stk))
        ((push!)
         (for-effect-only
          (set! stk (cons (second msg) stk))))
        ((top)
         (if (null? stk)
             (error "top: The stack is empty.")
             (car stk)))
        ((pop!)
         (for-effect-only
          (if (null? stk)
              (error "pop!: The stack is empty.")
              (set! stk (cdr stk)))))
        ((size) (length stk))
        ((print)
         (display "TOP: ")
         (for-each
          (lambda (x)
            (display x)
            (display " "))
          stk)
         (newline))
        (else (delegate base-object msg))))))

(define (queue-maker)
  (let ((q '()))
    (lambda msg
      (case (first msg)
        ((type) "queue")
        ((empty?) (null? q))
        ((enqueue!)
         (for-effect-only
          (let ((list-of-item (cons (second msg) '())))
            (if (null? q)
                (set! q list-of-item)
                (append! q list-of-item)))))
        ((front)
         (if (null? q)
             (error "front: The queue is empty.")
             (car q)))
        ((dequeue!)
         (for-effect-only
          (if (null? q)
              (error "dequeue!: The queue is empty.")
              (set! q (cdr q)))))
        ((size) (length q))
        ((print)
         (display "FRONT: ")
         (for-each
          (lambda (x) (display x) (display " "))
          q)
         (newline))
        (else (delegate base-object msg))))))

(define (bucket-maker)
  (let ((table '()))
    (lambda msg
      (case (first msg)
        ((type) "bucket")
        ((lookup)
         (let ((key (second msg))
               (succ (third msg))
               (fail (fourth msg)))
           (lookup key table (lambda (pr) (succ (cdr pr))) fail)))
        ((update!)
         (for-effect-only
          (let ((key (second msg))
                (updater (third msg))
                (initializer (fourth msg)))
            (lookup key table
                    (lambda (pr)
                      (set-cdr! pr (updater (cdr pr))))
                    (lambda ()
                      (let ((pr (cons key (initializer key))))
                        (set! table (cons pr table))))))))
        (else (delegate base-object msg))))))

(define (memoize proc)
  (let ((bucket (bucket-maker)))
    (lambda (arg)
      (send bucket 'update! arg (lambda (val) val) proc)
      (send bucket 'lookup arg
            (lambda (val) val) (lambda () #f)))))

(define (hash-table-maker size hash-fn)
  (let ((v ((vector-generator (lambda (i) (bucket-maker))) size)))
    (lambda msg
      (case (first msg)
        ((type) "hash table")
        (else
         (delegate (vector-ref v (hash-fn (second msg))) msg))))))