119 lines
3.2 KiB
Racket
119 lines
3.2 KiB
Racket
(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
|