;; Objekte sind Prozeduren, die Methoden zurückgeben

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

(define make-speaker
  (lambda ()
    (letrec
	((self
	  (lambda (message)
	    (cond ((eq? message 'say)
		   (lambda (stuff)
		     (display stuff)
		     (newline)))
		  (else (no-method 'speaker))))))
      self)))

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

(define no-method
  (lambda (name)
    (list 'no-method name)))

(define no-method?
  (lambda (x)
    (if (pair? x)
	(eq? (car x) 'no-method)
	#f)))

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

;; ASK besorgt sich eine Methode und ruft diese auf

(define ask
  (lambda (object message . args)
    (let ((method (get-method object message)))
      (if (method? method)
	  (apply method args)
	  (error "No method" message (cadr 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)
		  (ask self 'say stuff)
		  (ask 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)
		       (ask 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 ()
    (lambda (message)
      (cond ((eq? message 'say)
	     (lambda (self stuff)
	       (display stuff)
	       (newline)))
	    (else (no-method 'speaker))))))

;; ASK muß entsprechend geändert werden

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

;; Neue Dozenten und arrogante Dozenten

(define make-lecturer
  (lambda ()
    (let ((speaker (make-speaker)))
      (lambda (message)
	(cond
	 ((eq? message 'lecture)
	  (lambda (self stuff)
	    (ask self 'say stuff)
	    (ask 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)
		 (ask 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 (no-method 'singer))))))

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

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

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

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