list-objects/alsos.body.scm

;;;;; Foundational procedure definitions:
;;;;; has-ancestors? get-ancestors get-handler has-handler? resend send

(define (has-ancestors? obj)
  (let ((result (assq 'ancestors obj)))
    (and result
         (cdr result)
         (procedure? (cdr result))
         (let ((ancestors ((cdr result) obj)))
           (and (list? ancestors)
                (not (null? ancestors)))))))

(define (get-ancestors obj)
  (if (has-ancestors? obj)
      ((cdr (assq 'ancestors obj)) obj)
      '()))

(define (get-handler del msg)
  (and (list? del)
       (let ((handler (assq msg del)))
         (if handler
             handler
             (and (has-ancestors? del)
                  (let loop ((ancestors (get-ancestors del)))
                    (if (null? ancestors)
                        #f
                        (if (get-handler (car ancestors) msg)
                            (get-handler (car ancestors) msg)
                            (loop (cdr ancestors))))))))))

(define (has-handler? obj msg)
  (if (get-handler obj msg) #t #f))

(define (resend obj del msg . args)
  (let ((handler (get-handler del msg)))
    (if handler
        (if (or (procedure? (cdr handler))
                (not (null? args)))
            (apply (cdr handler) obj args)
            (cdr handler))
        ;; allow overriding behavior with message-not-understood
        (let ((not-understood-handler (get-handler del 'message-not-understood)))
          (if (and not-understood-handler (procedure? (cdr not-understood-handler)))
              ((cdr not-understood-handler) obj msg args)
              (error "send" "Message not understood" msg))))))

(define (send obj msg . args)
  (apply resend obj obj msg args))

;;;;; Syntax for defining operations:
;;;;; define-predicate define-operation

(define-syntax define-predicate
  (syntax-rules ()
    ((_ name)
     (define (name obj)
       (and (list? obj)
            (has-handler? obj 'name)
            (send obj 'name))))))

(define-syntax define-operation
  (syntax-rules ()
    ((_ (name obj args ...))
     (define (name obj args ...)
       (send obj 'name args ...)))
    ((_ (name obj args ...) default-behavior ...)
     (define (name obj args ...)
       (if (has-handler? obj 'name)
           (send obj 'name args ...)
           (let ()
             default-behavior ...))))
    ((_ (name obj . args))
     (define (name obj . args)
       (apply send obj 'name args)))
    ((_ (name obj . args) default-behavior ...)
     (define (name obj . args)
       (if (has-handler? obj 'name)
           (apply send obj 'name args)
           (let ()
             default-behavior ...))))))

;;;;; Syntax for creating objects and resending:
;;;;; object object-with-ancestors operate-as

(define-syntax object
  (syntax-rules ()
    ((_) '())
    ((_ ((msg self args ...) behavior ...) rest ...)
     (cons
      (cons 'msg
            (lambda (self args ...)
              behavior ...))
      (object rest ...)))
    ((_ ((msg self . args) behavior ...) rest ...)
     (cons
      (cons 'msg
            (lambda (self . args)
              behavior ...))
      (object rest ...)))))

(define-syntax object-with-ancestors
  (syntax-rules ()
    ((_ ((ancestor1 init1) ...) rest ...)
     (let ((ancestor1 init1) ...)
       (cons
        (cons 'ancestors
              (lambda (self)
                (list ancestor1 ...)))
        (object rest ...))))))

(define-syntax operate-as
  (syntax-rules ()
    ((_ del msg obj args ...)
     (resend obj del msg args ...))))

;;;;; Other helpful operations
;;;;; protocol simplify-object

(define (remove-dupes l)
  ;; remove duplicate keys from a list
  ;; not exported, helper for protocol
  (let loop ((result '())
             (next l))
    (if (null? next)
        (reverse result)
        (loop (if (memq (car next) result)
                  result
                  (cons (car next) result))
              (cdr next)))))

(define (expand-ancestors obj)
  ;; append an object with its ancestors
  ;; not exported, helper for protocol
  (append
   obj
   (apply append (map expand-ancestors (get-ancestors obj)))))

(define protocol
  (case-lambda
   ((obj)
    (remove-dupes (map car (expand-ancestors obj))))
   ((obj msg)
    (and (has-handler? obj msg)
         (cdr (get-handler obj msg))))))

(define (simplify-object obj keys)
  ;; sends each key to the object, returning an alist
  ;; with the resulting values
  (map (lambda (key)
         (cons key (send obj key)))
       keys))