linfo2335-programming-parad.../project-2/step3b.rkt

115 lines
3.0 KiB
Racket
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

(define (object)
(define super 'nil)
(define (self m)
(cond
((eq? m 'type) (lambda () 'object))
(else (lambda args (display (string-append "Message not understood: " (symbol->string m) "\n"))))
)
)
self
)
(define (point x y)
(define super (object))
(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 () (list 'point x y)))
(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 (self m)
(cond ((eq? m 'getx) (getx))
((eq? m 'gety) (gety))
((eq? m 'type) (type))
((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 (cons m args))))
)
)
self
)
(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)
((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 o (object))
(send o 'type) ; object
(send o 'foo) ; should display "Message not understood"
(define p1 (point 1 2))
(define p2 (point 3 4))
(send p1 'getx) ; 1
(send p1 'gety) ; 2
(send p2 'getx) ; 3
(send p2 'gety) ; 4
(define p (send p1 'add p2))
(send p 'info) ; (point 4 6)
(define cp (color-point 5 6 'red))
(send cp 'type) ; colorpoint
(send cp 'getx) ; 5
(send cp 'gety) ; 6
(send cp 'get-color) ; red
(send cp 'info)
(define cp1 (send cp 'add (color-point 1 2 'green)))
(send cp1 'type) ; colorpoint
(send cp1 'getx) ; 6
(send cp1 'gety) ; 8
(send cp1 'get-color) ; red