(define (new-instance class . parameters)
(let ((instance (apply class parameters)))
(virtual-operations instance)
instance))
(define (send message object . args)
(let ((method (method-lookup object message)))
(cond ((procedure? method) (apply method args))
((null? method) (error "Message not understood: " message))
(else (error "Inappropriate result of method lookup: " method)))))
; Arrange for virtual operations in object
(define (virtual-operations object)
(send 'set-self! object object))
(define (new-part class . parameters)
(apply class parameters))
(define (method-lookup object selector)
(cond ((procedure? object) (object selector))
(else (error "Inappropriate object in method-lookup: " object))))
(define (optional-parameter n optional-parameter-list . optional-default-value)
(let ((optional-default-value-1 (if (null? optional-default-value) #f (car optional-default-value))))
(if (> n (length optional-parameter-list))
optional-default-value-1
(let ((candidate-value (list-ref optional-parameter-list (- n 1))))
(if (eq? candidate-value 'non-passed-value)
optional-default-value-1
candidate-value)))))
; The root in the class hierarchy
(define (object)
(let ((super '())
(self 'nil))
(define (set-self! object-part)
(set! self object-part))
(define (dispatch message)
(cond ((eqv? message 'set-self!) set-self!)
(else (error "Undefined message" message))))
(set! self dispatch)
self))
; The class point
(define (point x y)
(let ((super (new-part object))
(self 'nil))
(let ((x x)
(y y)
)
(define (getx) x)
(define (gety) y)
(define (add p)
(let ((class-to-instantiate (send 'class-of self)))
(new-instance
class-to-instantiate
(+ x (send 'getx p))
(+ y (send 'gety p)) )))
(define (type-of) 'point)
(define (class-of) point)
(define (point-info)
(list (send 'getx self) (send 'gety self) (send 'type-of self)))
(define (set-self! object-part)
(set! self object-part)
(send 'set-self! super object-part))
(define (self message)
(cond ((eqv? message 'getx) getx)
((eqv? message 'gety) gety)
((eqv? message 'add) add)
((eqv? message 'type-of) type-of)
((eqv? message 'class-of) class-of)
((eqv? message 'point-info) point-info)
((eqv? message 'set-self!) set-self!)
(else (method-lookup super message))))
self)))
; The class color-point which inherits from point
; A color point can be initialized with and without a color.
; The color defaults to blue
(define (color-point x y . optional-parameter-list)
(let ((super (new-part point x y))
(self 'nil))
(let ((color (optional-parameter 1 optional-parameter-list 'blue)))
(define (get-color)
color)
(define (type-of) 'color-point)
(define (set-self! object-part)
(set! self object-part)
(send 'set-self! super object-part))
; Redefinition from point. This is done to combine the colors of the two points.
; You can delete this method (and its selector in dispatch). Without add here
; the colors will not combine. Try it.
(define (add p)
(let ((class-to-instantiate (send 'class-of self)))
(new-instance
class-to-instantiate
(+ x (send 'getx p))
(+ y (send 'gety p))
(list color (send 'get-color p))
)))
(define (class-of) color-point)
(define (dispatch message)
(cond ((eqv? message 'get-color) get-color)
((eqv? message 'type-of) type-of)
((eqv? message 'set-self!) set-self!)
((eqv? message 'class-of) class-of)
((eqv? message 'add) add)
(else (method-lookup super message))))
(set! self dispatch))
self))
; (define cp (new-instance color-point 5 6 'red))
; (list (send 'getx cp) (send 'gety cp) (send 'get-color cp))
; (send 'point-info cp)
; (define cp-1 (send 'add cp (new-instance color-point 1 2 'green)))
; (list (send 'getx cp-1) (send 'gety cp-1) (send 'get-color cp-1))
; (send 'point-info cp-1)