(define (new-instance class . parameters)
 (let ((instance (apply class parameters)))
   (virtual-operations instance)
   instance))

; Arrange for virtual operations in object
(define (virtual-operations object)
  (send 'set-self! object object))

(define (new-part class . parameters)
  (apply class parameters))

(define (method-lookup object selector)
  (cond ((procedure? object) (object selector))
         (else (error "Inappropriate object in method-lookup: " object))))

(define (send message object . args)
  (let ((method (method-lookup object message)))
    (cond ((procedure? method) (apply method args))
          ((null? method) (error "Message not understood: " message))
          (else (error "Inappropriate result of method lookup: " method)))))



; The root in the class hierarchy
(define (object)
  (let ((super '())
        (self 'nil))

   (define (set-self! object-part)
     (set! self object-part))

   (define (dispatch message)
      (cond ((eqv? message 'set-self!) set-self!)
            (else (error "Undefined message" message))))
 
   (set! self dispatch)
   self))


; The class point
(define (point x y)
 (let ((super (new-part object))
       (self 'nil))

   (let ((x x) 
         (y y)
        )
     
     (define (getx) x)

     (define (gety) y)

     (define (add p) 
      (let ((class-to-instantiate (send 'class-of self)))
       (class-to-instantiate
        (+ x (send 'getx p))
        (+ y (send 'gety p))
     )))

     (define (type-of) 'point)

     (define (class-of) point)

     (define (set-self! object-part)
         (set! self object-part)
         (send 'set-self! super object-part))
     
     (define (self message)
         (cond ((eqv? message 'getx) getx)
               ((eqv? message 'gety) gety)
               ((eqv? message 'add)  add)
               ((eqv? message 'type-of) type-of)
               ((eqv? message 'class-of) class-of)
               ((eqv? message 'set-self!) set-self!)
               (else (method-lookup super message))))
     
      self)))



; The class color-point which inherits from point
; A color point can be initialized with and without a color. 
; The color defaults to blue

(define (color-point x y . optional-parameter-list)
 (let ((super (new-part point x y))
       (self 'nil))
   (let ((color (optional-parameter 1 optional-parameter-list 'blue)))
       
     (define (get-color)
       color)

     (define (type-of) 'color-point)

     (define (set-self! object-part)
         (set! self object-part)
         (send 'set-self! super object-part))

     ; Redefinition from point. This is done to combine the colors of the two points.
     ; You can delete this method (and its selector in dispatch). Without add here
     ; the colors will not combine. Try it.
     (define (add p) 
      (let ((class-to-instantiate (send 'class-of self)))
       (class-to-instantiate
        (+ x (send 'getx p))
        (+ y (send 'gety p))
        (list color (send 'get-color p))
     )))

     (define (class-of) color-point)
       
     (define (dispatch message)
       (cond ((eqv? message 'get-color) get-color)
             ((eqv? message 'type-of) type-of)
             ((eqv? message 'set-self!) set-self!)
             ((eqv? message 'class-of) class-of)
             ((eqv? message 'add)  add)
             (else (method-lookup super message))))
       
     (set! self dispatch))
     
   self))