(define (object)
	(define super 'nil)
	(define (self m)
		(cond
			((eq? m 'type) (lambda () 'object))
		  (else (lambda args (display (string-append "Message not understood: " (symbol->string m) "\n"))))
		)
	)
	self
)

(define (point x y)
	(define super (object))
  (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 () (list 'point x y)))
  (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 (self m)
    (cond ((eq? m 'getx) (getx))
          ((eq? m 'gety) (gety))
          ((eq? m 'type) (type))
          ((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 (cons m args))))
		)
	)
  self
 )

(define (color-point x y color)
	(define super (point x y))
	(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 (self m)
		(cond ((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))))
		)
	)
	self
)

(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 o (object))
(send o 'type) ; object
(send o 'foo) ; should display "Message not understood"

(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)

(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