step5 attempt

project-2/step5_attempt.rkt

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