Update step_5.rkt : implementing a CompareTo function in both the point and color-point classes.

Adding getters and setters in the color-point class.

step_5.rkt

@@ -3,9 +3,11 @@
 ;           Nicolas Rosar   - 1443 1900
 ;           Group F
 
-; In this step, we improved the error message when the receiver object is inappropriate.
-; We added information to mention the receiver object.
+; In this final optional step, we've tried to approach our implementation even more of object-oriented programming
+; by adding more functions proper to object-oriented classes.
+; For example, the compare to method
 
+; Object class, root of the inheritance hierarchy.
 (define (object)
   (define super 'nil)
   (define self_ref #f)
@@ -14,31 +16,10 @@
   (define (self m)
     (cond ((eq? m 'type) (gettype))
           ((eq? m 'set-self!) set-self!)
-          (else (display "Error : Message not understood"))))
-  self)
-
-(define (color-point x y color)
-  (define self_ref #f)
-  (define super (point x y))
-  (define (set-self! ref)
-    (begin
-      (set! self_ref ref)
-      ((super 'set-self!) ref)
-      ))
-  (define (getcolor) color)
-  (define (gettype) 'color-point)
-  (define (getinfo) (append (send super 'info) (list (getcolor))))
-  (define (add cp)
-    (color-point (+ (super 'getx) (cp 'getx)) (+ (super '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!) set-self!)
-          (else (super m))))
+          (else (display "Message not understood"))))
   self)
 
+; Point object class
 (define (point x y)
   (define self_ref #f)
   (define (set-self! ref)
@@ -46,6 +27,7 @@
       (set! self_ref ref)
       ((super 'set-self!) ref)
       ))
+  (define (get-self_ref) self_ref)
   (define super (new object))
   (define (getx) x )
   (define (gety) y )
@@ -54,7 +36,20 @@
   (define (setx value)(set! x value))
   (define (sety value)(set! y value))
   (define (add p)
-    (point (+ (getx) (send p 'getx)) (+ (gety) (send p 'gety))))
+    (new point (+ (getx) (send p 'getx)) (+ (gety) (send p 'gety))))
+  ; New compateTo method, allowing to compare a point to another one.
+  ; It first verifies if either the two objects are of the same type, i.e. points,
+  ; or if the object with which we do the comparison is a child object of this class, i.e.,
+  ; comparing a point to a color-point should be possible.
+  
+  ; It simply checks if the two points have the same coordinates, i.e.,
+  ; the same x and y values respectively.
+  (define (compareTo p)
+    (if (or (eq? (send p 'type) (gettype)) (eq? (send (send p 'super) 'type) (gettype)) ) 
+        (and (eq? (getx) (send p 'getx)) (eq? (gety) (send p 'gety)) )
+        #f
+        )
+    )
   (define (self m)
     (cond ((eq? m 'getx) getx)
           ((eq? m 'gety) gety)
@@ -65,21 +60,72 @@
           ((eq? m 'add) add)
           ((eq? m 'child) (send self 'getcolor))
           ((eq? m 'set-self!) set-self!)
+          ; Added two new messages
+          ((eq? m 'compareTo) compareTo)
+          ((eq? m 'super) super)
           (else (super m))))
   self)
 
+; Color-point object class
+(define (color-point x y color)
+  (define self_ref #f)
+  (define super (point x y))
+  (define (get-super) super)
+  (define (set-self! ref)
+    (begin
+      (set! self_ref ref)
+      ((super 'set-self!) ref)
+      ))
+  (define (getcolor) color)
+  ; Added getter functions (getx and gety) implemented using super.
+  (define (getx) (send super 'getx))
+  (define (gety) (send super 'gety))
+  ; Added setter functions (setx! and sety!) implemented using super.
+  (define (setx! value) (send super 'setx value))
+  (define (sety! value) (send super 'sety value))
+  (define (gettype) 'color-point)
+  (define (getinfo) (append (send super 'info) (list (getcolor))))
+  (define (add cp)
+    (new color-point (+ (super 'getx) (cp 'getx)) (+ (super 'gety) (cp 'gety)) (getcolor)))
+  ; New compateTo method, allowing to compare a color-point to another one.
+  ; It first checks that the other object is indeed a color-point too.
+  ; Then, it checks if the colors of both color-points are the same.
+  ; Finally, it checks that the coordinates of the points are the same by calling the parent method.
+  (define (compareTo cp)
+    (if (eq? (send cp 'type) (gettype)) 
+        (and (eq? (getcolor) (send cp 'get-color)) (send super 'compareTo (send cp 'super)) )
+        #f)
+    )
+  (define (self m)
+    (cond ((eq? m 'get-color) getcolor)
+          ((eq? m 'getx) getx)
+          ((eq? m 'gety) gety)
+          ((eq? m 'info) getinfo)
+          ((eq? m 'type) gettype)
+          ((eq? m 'add)  add)
+          ((eq? m 'set-self!) set-self!)
+          ; Added two new messages
+          ((eq? m 'compareTo) compareTo)
+          ((eq? m 'super) get-super)
+          (else (super m))))
+  self)
 
+; Send method to pass messages to objects
 (define (send p m . args)
   (if (procedure? p)
+      
       (cond
         ((null? args) ((p m)))
-        (else 
-          ((p m) (car args))
-        ))
-      (display (list "Error : Inappropriate receiver object :" p)) )
- )
-
+        (else
+         (if (procedure? (p m))
+             ((p m) (car args))
+             )
+         ) 
+        )
+      (display "Inappropriate receiver object") )
+  )
 
+; The new construtctor procedure, to create new instances of objects
 (define (new object-class . class-args)
   (let ((new_object (apply object-class class-args)))
     (begin
@@ -89,8 +135,68 @@
     )
   )
 
+; Sample code illustrating the execution of the step.
+; Create three points, and try comparing them between each other.
+(define p1 (new point 1 2))
+(define p2 (new point 3 2))
+(define p3 (new point 1 2))
 
+(display (send p1 'compareTo p2)) ; should display : #f
+(newline)
+(display (send p1 'compareTo p3)) ; should display : #t
+(newline)
+(display (send p2 'compareTo p3)) ; should display : #f
+(newline)
 
-(define p 5)
-(display (send p 'info )) ; should display : (Inappropriate receiver object : 5)#<void>
+(display '----------)
+(newline)
+
+; Create four color-points, and try comparing them between each other.
+; We do this to check that the inheritance works properly.
+(define cp1 (new color-point 1 2 'red))
+(define cp2 (new color-point 1 2 'blue))
+(define cp3 (new color-point 1 2 'red))
+(define cp4 (new color-point 3 4 'blue))
+
+(display (send cp1 'compareTo cp2)) ; should display : #f
+(newline)
+(display (send cp1 'compareTo cp3)) ; should display : #t
+(newline)
+(display (send cp1 'compareTo cp4)) ; should display : #f
+(newline)
+(display (send cp2 'compareTo cp3)) ; should display : #f
+(newline)
+(display (send cp2 'compareTo cp4)) ; should display : #f
+(newline)
+(display (send cp3 'compareTo cp4)) ; should display : #f
+(newline)
+
+(display '----------)
+(newline)
+
+; Cross comparison between classes.
+
+; The comparison between a point, from a the point of vue of a point object, to a color-point of same coordinates
+; will work since we do not care about the color of the object.
+
+(display (send p1 'compareTo cp3)) ; should display : #t
+(newline)
+
+; Here it will not work because there is not reason to try to compare
+; a point to a color-point from a color-point point of vue.
+; Since we check at first in the compareTo method from the color-point class
+; if the object with which the comparison will be made is indeed or not a color-point too,
+; it directly produces a #f (false) return value.
+
+(display (send cp3 'compareTo p1)) ; should display : #f
+(newline)
+
+(display '----------)
+(newline)
+
+; Testing the new getters and setters for the color-point class, implemented using the super functions.
+(display (send cp1 'getx)) ; should display : 1
+(newline)
+(send cp1 'setx! 3)
+(display (send cp1 'getx)) ; should display : 3
 (newline)