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

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"))))