;; Objekte sind Prozeduren, die Methoden zurückgeben

(define get-method
  (lambda (object message)
    (object message)))

(define make-speaker
  (lambda ()
    (let ((slaps 0))
      (letrec
          ((self
            (lambda (message)
              (cond ((eq? message 'say)
                     (lambda (stuff)
                       (display stuff)
                       (newline)))
                    ((eq? message 'slap)
                     (lambda ()
                       (set! slaps (+ 1 slaps))
                       (if (= slaps 3)
                           (begin
                             ((self 'say) '(ouch!))
                             (set! slaps 0)))))
                    (else (make-no-method 'speaker))))))
        self))))

;; Der Rückgabewert von NO-METHOD muß von Methoden unterscheidbar
;; sein

(define no-method-type (make-type 'no-method))

(define make-no-method (typed-value-maker no-method-type))

(define no-method? (typed-value-predicate no-method-type))

(define no-method-message (typed-value-selector no-method-type))

(define method?
  (lambda (x)
    (not (no-method? x))))

;; SEND besorgt sich eine Methode und ruft diese auf

(define send
  (lambda (object message . args)
    (let ((method (get-method object message)))
      (if (method? method)
          (apply method args)
          (error "No method" message (no-method-message method))))))

;; Ein Dozent ist auch ein Redner

(define make-lecturer
  (lambda ()
    (let ((speaker (make-speaker)))
      (letrec
          ((self
            (lambda (message)
              (cond
               ((eq? message 'lecture)
                (lambda (stuff)
                  (send self 'say stuff)
                  (send self 'say '(abstraction abstraction abstraction))))
               (else
                (get-method speaker message))))))
        self))))

;; Ein arroganter Dozent ist auch ein Dozent

(define make-arrogant-lecturer
  (lambda ()
    (let ((lecturer (make-lecturer)))
      (letrec
          ((self
            (lambda (message)
              (cond ((eq? message 'say)
                     (lambda (stuff)
                       (send lecturer 'say
                            (append '(it is obvious that)
                                    stuff))))
                    (else (get-method lecturer message))))))
        self))))

;; Methoden brauchen einen anderen Begriff von SELF, damit
;; ARROGANT-LECTURER richtig funktionieren kann

(define make-speaker
  (lambda ()
    (let ((slaps 0))
      (lambda (message)
	(cond ((eq? message 'say)
	       (lambda (self stuff)
		 (display stuff)
		 (newline)))
	      ((eq? message 'slap)
	       (lambda (self)
		 (set! slaps (+ 1 slaps))
		 (if (= slaps 3)
		     (begin
		       (send self 'say '(ouch!))
		       (set! slaps 0)))))
	      (else (make-no-method 'speaker)))))))

;; SEND muß entsprechend geändert werden

(define send
  (lambda (object message . args)
    (let ((method (get-method object message)))
      (if (method? method)
	  (apply method (cons object args))
	  (error "No method" message (no-method-message method))))))

;; Neue Dozenten und arrogante Dozenten

(define make-lecturer
  (lambda ()
    (let ((speaker (make-speaker)))
      (lambda (message)
	(cond
	 ((eq? message 'lecture)
	  (lambda (self stuff)
	    (send self 'say stuff)
	    (send self 'say '(abstraction abstraction abstraction))))
	 (else
	  (get-method speaker message)))))))

(define make-arrogant-lecturer
  (lambda ()
    (let ((lecturer (make-lecturer)))
      (lambda (message)
	(cond ((eq? message 'say)
	       (lambda (self stuff)
		 (send lecturer 'say
		       (append '(it is obvious that)
			       stuff))))
	      (else (get-method lecturer message)))))))

;; Eine Sängerin bzw. ein Sänger kann auch sprechen

(define make-singer
  (lambda ()
    (lambda (message)
      (cond
       ((eq? message 'say)
	(lambda (self stuff)
	  (display (append '(tra-la-la) stuff))
	  (newline)))
       ((eq? message 'sing)
	(lambda (self)
	  (display '(tra-la-la))
	  (newline)))
       (else (make-no-method 'singer))))))

;; Madonna ist zuerst Sängerin, erst dann Dozentin

(define madonna
  (let ((singer (make-singer))
        (lecturer (make-lecturer)))
    (lambda (message)
      (let ((singer-method (get-method singer message)))
        (if (method? singer-method)
            singer-method
            (get-method lecturer message))))))

;; Norbert ist zuerst Dozent, erst dann Sänger

(define norbert
  (let ((singer (make-singer))
        (lecturer (make-lecturer)))
    (lambda (message)
      (let ((lecturer-method (get-method lecturer message)))
	(if (method? lecturer-method)
	    lecturer-method
	    (get-method singer message))))))