(define-syntax define-class
  (syntax-rules ()
    ((_ (class-name . args) body ...)
     (let ()
       (define (class-name . args)
         (let ((self ()))
           (define (dispatch m)
             (cond
               ((eq? m 'self) self)
               ((eq? m 'type) (lambda () 'class-name))
               ((eq? m 'init)
                (lambda args
                  (set! self (apply class-name args))
                  self))
               ((eq? m 'dispatch) dispatch)
               (else (error "Unknown method" m)))))
           body ...
           dispatch)))))

(define-class (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")))))))
  
(define-class (point x y)
  (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-class (color-point x y color)
  (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 (send receiver . message)
  (if (procedure? receiver)
      ((receiver 'dispatch) message)
      (display (string-append "Inappropriate receiver object: " (symbol->string receiver) "\n"))))