Step 3b: color-point
This commit is contained in:
parent
0248f59c0d
commit
9f09eaeb20
|
@ -3,7 +3,7 @@
|
|||
(define (self m)
|
||||
(cond
|
||||
((eq? m 'type) (lambda () 'object))
|
||||
(else (lambda () (display (string-append "Message not understood: " (symbol->string m) "\n"))))
|
||||
(else (lambda args (display (string-append "Message not understood: " (symbol->string m) "\n"))))
|
||||
)
|
||||
)
|
||||
self
|
||||
|
@ -29,6 +29,7 @@
|
|||
(point (- x px) (- y py))
|
||||
)
|
||||
))
|
||||
|
||||
(define (self m)
|
||||
(cond ((eq? m 'getx) (getx))
|
||||
((eq? m 'gety) (gety))
|
||||
|
@ -38,18 +39,40 @@
|
|||
((eq? m 'info) (info))
|
||||
((eq? m 'add) (add))
|
||||
((eq? m 'sub) (sub))
|
||||
(else (lambda () (method-lookup super (list m))))
|
||||
(else (lambda args (method-lookup super (cons m args))))
|
||||
)
|
||||
)
|
||||
self
|
||||
)
|
||||
|
||||
(define (send2 obj . args)
|
||||
(if (procedure? obj)
|
||||
(if (= (length args) 1)
|
||||
((obj (car args)))
|
||||
((obj (car args)) (car (cdr args)))) ; Extracting the second argument
|
||||
(display (string-append "Inappropriate receiver object: " (symbol->string obj) "\n"))))
|
||||
(define (color-point x y color)
|
||||
(define super (point x y))
|
||||
(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 (self m)
|
||||
(cond ((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))))
|
||||
)
|
||||
)
|
||||
self
|
||||
)
|
||||
|
||||
(define (method-lookup reciever message)
|
||||
(if (= (length message) 1)
|
||||
|
@ -64,6 +87,9 @@
|
|||
)
|
||||
)
|
||||
|
||||
(define o (object))
|
||||
(send o 'type) ; object
|
||||
(send o 'foo) ; should display "Message not understood"
|
||||
|
||||
(define p1 (point 1 2))
|
||||
(define p2 (point 3 4))
|
||||
|
@ -72,11 +98,17 @@
|
|||
(send p2 'getx) ; 3
|
||||
(send p2 'gety) ; 4
|
||||
(define p (send p1 'add p2))
|
||||
(send p 'test);
|
||||
(send p 'info) ; (point 4 6)
|
||||
(send 'not-a-point 'info) ; should display "Inappropriate receiver object"
|
||||
(send p 'foo) ; should display "Message not understood"
|
||||
; Same issue than step3
|
||||
;(send p 'bar 2) ; should display "Message not understood"
|
||||
(send p1 'setx! 5)
|
||||
(send p1 'getx) ; returns 5
|
||||
|
||||
(define cp (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)
|
||||
|
||||
(define cp−1 (send cp 'add (color-point 1 2 'green)))
|
||||
(send cp−1 'type) ; color−point
|
||||
(send cp−1 'getx) ; 6
|
||||
(send cp−1 'gety) ; 8
|
||||
(send cp−1 'get-color) ; red
|
||||
|
|
Loading…
Reference in New Issue