Exercises in this lecture   Go to the notes, in which this exercise belongs -- Keyboard shortcut: 'u'   Alphabetic index   Course home   

Exercise solution:
Color Point Extensions

Here is my solution. The solution relies on a non-standard function optional-parameter, which I use a lot in my LAML stuff. The function (and others) can be found here. (You can access the function defintion by clicking on the Scheme source file in the documentation).

(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)