step5 attempt
This commit is contained in:
parent
24434d5cf7
commit
ea772aa8fa
|
@ -0,0 +1,59 @@
|
|||
(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"))))
|
Loading…
Reference in New Issue