Objects and Lambda

Say we wish to construct a ``dog'' object, which responds to the messages bark and describe. We will represent dogs as anonymous functions, created by a make-dog routine. To send a message to a dog, we call it with the first argument being a selector which says what kind of message is being sent, and the remaining arguments being arguments for that particular method.

(define (send object selector . args)
  (apply object (cons selector args)))

(define (make-dog size)
  (lambda (selector . args)
    (cond ((equal? selector 'bark)
           (cond ((equal? size 'small) 'yip)
                 ((equal? size 'medium) 'arf)
                 ((equal? size 'large) 'woof)))
          ((equal? selector 'describe)
           (list 'dog 'size size))
          (else (error "DOG: unknown selector ~A" selector)))))

(define fifi (make-dog 'small))
(define spot (make-dog 'medium))
(define duke (make-dog 'large))

(send fifi 'bark)      ; yip

• The methods for a single type cannot be textually dispersed.
• There is no inheritence.
• An object cannot send itself a message.
• We cannot define system message handlers, eg so that dogs could print themselves with special syntax.

Objects cannot send messages to themselves in the above code because they do not have references to themselves available. We can correct this problem quite easily, by simply arranging for the send procedure to send each object an extra argument: a reference to itself.

(define (send object selector . args)
  (apply object (cons selector (cons object args))))

(define (make-dog size)
  (lambda (selector self . args)
    (cond ((equal? selector 'bark)
           (cond ((equal? size 'small) 'yip)
                 ((equal? size 'medium) 'arf)
                 ((equal? size 'large) 'woof)))
          ((equal? selector 'describe)
           (list 'dog 'size size))
	  ((equal? selector 'see-cat)
	   (list (send self 'bark)
                 (send self 'bark)
                 (send self 'bark)))
          (else (error "DOG: unknown selector ~A" selector)))))

(define fifi (make-dog 'small))

(send fifi 'see-cat)             ; (yip yip yip)

Objects can now send messages to themselves, but there is still no inheritance. There are two kinds of inheritance used in object-oriented programming languages: supertypes, and delegation. In languages with supertype inheritance, such as C++ or Smalltalk, objects are members of a type, and a type can inherit from a supertype. But in our way of defining objects there are no types as such! Instead, we will modify our objects to each have an optional delegate, who will handle messages they don't handle themselves for them. The delegate is just another object like any other, not distinguished in any way.

Let us make an example: we will make two kinds of point objects, which represent their coordinates in polar vs rectangular coordinates. Each such object will delegate to a generic point object, which knows how to handle any messages which should be handled in common.

(define (send object selector . args)
  (apply object (cons selector (cons object args))))

(define (delegate parent object selector args)
  (apply parent (cons selector (cons object args))))

(define generic-point
  (lambda (selector self . args)
    (cond ((equal? selector 'DESCRIBE-RECT)
           (list 'rect
                 (send self 'get-x)
                 (send self 'get-y)))
          ((equal? selector 'DESCRIBE-POLAR)
           (list 'polar
                 (send self 'get-radius)
                 (send self 'get-angle)))
          ((equal? selector 'SCALE)
           (make-polar-point (* (car args) (send self 'get-radius))
                             (send self 'get-angle)))
          ((equal? selector '+)
           (make-rect-point (+ (send self 'get-x)
                               (send (car args) 'get-x))
			    (+ (send self 'get-y)
			       (send (car args) 'get-y))))
          (else (error "Unknown selector ~A" selector)))))

(define (make-rect-point x y)
  (lambda (selector self . args)
    (cond ((equal? selector 'GET-X) x)
          ((equal? selector 'GET-Y) y)
          ((equal? selector 'GET-RADIUS)
           (sqrt (+ (* x x) (* y y))))
          ((equal? selector 'GET-ANGLE)
           (atan y x))
          ((equal? selector 'SCALE)
           (make-rect-point (* (car args) x)
                            (* (car args) y)))
          (else
           (delegate generic-point self selector args)))))

(define (make-polar-point radius angle)
  (lambda (selector self . args)
    (cond ((equal? selector 'GET-X) (* radius (sin angle)))
          ((equal? selector 'GET-Y) (* radius (cos angle)))
          ((equal? selector 'GET-RADIUS) radius)
          ((equal? selector 'GET-ANGLE) angle)
          (else
           (delegate generic-point self selector args)))))

(define p1 (make-rect-point 1 1))
(define p2 (make-rect-point 2 3))
(define p3 (send p1 '+ p2))
(define p4 (send p3 'scale 2))

(send p4 'describe-rect)              ; (rect 5 8)
(send p4 'describe-polar)             ; (polar 10 0.927)