Step 4

project-2/step4.rkt

@@ -0,0 +1,118 @@
+(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