diff --git a/project-2/step5.rkt b/project-2/step5.rkt new file mode 100644 index 0000000..eabc9b5 --- /dev/null +++ b/project-2/step5.rkt @@ -0,0 +1,118 @@ +(define (object) + (define super 'nil) + (define self 'nil) + (define (set-self!) (lambda (s) (set! self s))) + (define (internal m) + (cond + ((eq? m 'type) (lambda () 'object)) + ((eq? m 'info) (lambda () (list (send self 'type)))) + ((eq? m 'set-self!) (set-self!)) + (else (lambda args (display (string-append "Message not understood: " (symbol->string m) "\n")))) + ) + ) + internal +) + +(define (point x y) + (define super (object)) + (define self 'nil) + (define (set-self!) (lambda (s) + (set! self s) + (method-lookup super (list 'set-self! s)) + )) + (define (getx) (lambda () x)) + (define (gety) (lambda () y)) + (define (type) (lambda () 'point)) + (define (setx!) (lambda (nx) (set! x nx))) + (define (sety!) (lambda (ny) (set! y ny))) + (define (info) (lambda () (append ((super 'info)) (list x)))) + (define (add) (lambda (p) + (let ((px ((p 'getx))) + (py ((p 'gety)))) + (point (+ x px) (+ y py)) + ) + )) + (define (sub) (lambda (p) + (let ((px ((p 'getx))) + (py ((p 'gety)))) + (point (- x px) (- y py)) + ) + )) + + (define (internal m) + (cond ((eq? m 'set-self!) (set-self!)) + ((eq? m 'type) (type)) + ((eq? m 'getx) (getx)) + ((eq? m 'gety) (gety)) + ((eq? m 'setx!) (setx!)) + ((eq? m 'sety!) (sety!)) + ((eq? m 'info) (info)) + ((eq? m 'add) (add)) + ((eq? m 'sub) (sub)) + (else (lambda args (method-lookup super (list m args)))) + ) + ) + internal + ) + +(define (color-point x y color) + (define super (point x y)) + (define self 'nil) + (define (set-self!) (lambda (s) + (set! self s) + (method-lookup super (list 'set-self! s)) + )) + (define (type) (lambda () 'color-point)) + (define (get-color) (lambda () color)) + (define (info) (lambda () (append ((super 'info)) (list color)))) + (define (add) (lambda (p) + (let ((px ((p 'getx))) + (py ((p 'gety)))) + (color-point (+ x px) (+ y py) color) + ) + )) + (define (sub) (lambda (p) + (let ((px ((p 'getx))) + (py ((p 'gety)))) + (color-point (- x px) (- y py) color) + ) + )) + + (define (internal m) + (cond ((eq? m 'set-self!) (set-self!)) + ((eq? m 'type) (type)) + ((eq? m 'get-color) (get-color)) + ((eq? m 'info) (info)) + ((eq? m 'add) (add)) + (else (lambda args (method-lookup super (cons m args)))) + ) + ) + internal +) + +(define (method-lookup reciever message) + (if (= (length message) 1) + ((reciever (car message))) + ((reciever (car message)) (car (cdr message))) + )) + +(define (send reciever . message) + (if (procedure? reciever) + (method-lookup reciever message) + (display (string-append "Inappropriate receiver object: " (symbol->string reciever) "\n")) + ) + ) + +(define (new cls . args) + (let ((object (apply cls args))) + (send object 'set-self! object) + object + ) +) + +(define cp (new color-point 5 6 'red)) +(send cp 'type) ; color−point +(send cp 'getx) ; 5 +(send cp 'gety) ; 6 +(send cp 'get-color) ; red +(send cp 'info) ; (color−point 5 6 red