Upload New File

step_3b.rkt

+(define (object)
+  (define (gettype) 'object)
+  (define (self m)
+    (cond ((eq? m 'type) (gettype))
+          (else (display "Message not understood"))))
+  self)
+
+(define (color-point x y color)
+  (define mypoint (point x y))
+  (define (getcolor) color)
+  (define (gettype) 'color-point)
+  (define (getinfo) (list (self 'type) (mypoint 'getx) (mypoint 'gety) (self 'get-color)))
+  (define (add cp)
+    (color-point (+ (mypoint 'getx) (cp 'getx)) (+ (mypoint 'gety) (cp 'gety)) (getcolor)))
+  (define (self m)
+    (cond ((eq? m 'get-color) (getcolor))
+          ((eq? m 'info) (getinfo))
+          ((eq? m 'type) (gettype))
+          ((eq? m 'add)  add)
+          (else (send mypoint m))))
+  self)
+
+(define (point x y)
+  (define myobject (object))
+  (define (getx) x )
+  (define (gety) y )
+  (define (gettype) 'point )
+  (define (getinfo)(list (self 'type) (self 'getx) (self 'gety)))
+  (define (setx value)(set! x value))
+  (define (sety value)(set! y value))
+  (define (add p)
+    (point (+ (getx) (p 'getx)) (+ (gety) (p 'gety))))
+  (define (self m)
+    (cond ((eq? m 'getx) (getx))
+          ((eq? m 'gety) (gety))
+          ((eq? m 'type) (gettype))
+          ((eq? m 'info) (getinfo))
+          ((eq? m 'setx!) setx)
+          ((eq? m 'sety!) sety)
+          ((eq? m 'add) add)
+          (else (send myobject m))))
+  self)
+
+(define (send p m . args)
+  (if (procedure? p)
+      (cond
+        ((null? args) (p m))
+        (else ((p m) (car args)))
+        )
+      (display "Inappropriate receiver object") )
+ )
+
+
+; Test part 2
+( define o ( object ) ) (newline)
+( send o ' type ) ; o b j e c t
+( send o ' foo ) ; should d i s p l a y ” Message not understood ”
+(newline)
+
+( define p1 ( point 1 2 ) )
+( define p2 ( point 3 4 ) )
+( send p1 ' getx ) ; 1
+( send p1 ' gety ) ; 2
+( send p2 ' getx ) ; 3
+( send p2 ' gety ) ; 4
+
+( define p ( send p1 'add p2 ) )
+( send p 'info ) ; ( point 4 6)
+
+(newline)
+( define cp ( 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 )
+
+( define cp-1 ( send cp 'add ( color-point 1 2 'green ) ) )
+( send cp-1 'type ) ; color-point
+( send cp-1 'getx ) ; 6
+( send cp-1 'gety ) ; 8
+( send cp-1 'get-color ) ; red
\ No newline at end of file