Upload New File

step_4.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)
+          ((eq? m 'set-self!) (display 'set_self_working))
+          (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)
+          ((eq? m 'child) (send self 'getcolor))
+          (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") )
+ )
+
+
+(define (new object-class . class-args)
+  (cond ((eq? object-class color-point)
+         (if (eq? (length class-args) 3)
+             (let ((temp (color-point (car class-args) (cadr class-args) (caddr class-args))))
+               (begin
+                 (temp 'set-self!)
+                 temp
+                 )
+               )
+               (display "SON PERE")
+         ))
+        ((eq? object-class point)
+         (if (eq? (length class-args) 2)
+             (point (car class-args) (cadr class-args))
+             (display "SON PERE")
+         ))
+        ((eq? object-class object)
+         (if (eq? (length class-args) 0)
+             (object)
+             (display "SON PERE")
+         ))
+          )
+  )
+
+(eq? color-point point)
+( define cp ( new color-point 5 6 'red ) )
+( send cp 'type ) ; c o l o r - p o i n t
+( send cp 'getx ) ; 5
+( send cp 'gety ) ; 6
+( send cp 'get-color ) ; red
+( send cp 'info ) ; ( c o l o r - p o i n t 5 6 red )