60 lines
2.1 KiB
Racket
60 lines
2.1 KiB
Racket
(define-syntax define-class
|
|
(syntax-rules ()
|
|
((_ (class-name . args) body ...)
|
|
(let ()
|
|
(define (class-name . args)
|
|
(let ((self ()))
|
|
(define (dispatch m)
|
|
(cond
|
|
((eq? m 'self) self)
|
|
((eq? m 'type) (lambda () 'class-name))
|
|
((eq? m 'init)
|
|
(lambda args
|
|
(set! self (apply class-name args))
|
|
self))
|
|
((eq? m 'dispatch) dispatch)
|
|
(else (error "Unknown method" m)))))
|
|
body ...
|
|
dispatch)))))
|
|
|
|
(define-class (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")))))))
|
|
|
|
(define-class (point x y)
|
|
(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-class (color-point x y color)
|
|
(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 (send receiver . message)
|
|
(if (procedure? receiver)
|
|
((receiver 'dispatch) message)
|
|
(display (string-append "Inappropriate receiver object: " (symbol->string receiver) "\n"))))
|