;;; Konstruktion, Vorlesung vom 09.01.2001
;;; K12 Objekt-orientierte Programmierung

;;; K12.1 Objekte und Methoden

;;; OBJEKT: Wert mit Identität, Fähigkeiten und Gedächtnis
;;;  Identität   - jedes Objekt kann sich unabhängig von anderen entwicklen
;;;  Fähigkeiten - angestossen duch Empfang von Nachrichten
;;;  Gedächtnis  - ein Objekt kann internen Zustand haben

;;; METHODE: Fähigkeit eines Objekts; bestimmt die Aktion bei Empfang 
;;;  einer bestimmten Nachricht eines Objekts













;;; Implementierung einer Methode

;;; Eine Methode ist eine Operation, die fest einem Objekt zugeordnet ist.
;;; Sie hat Zugriff auf das Objekt und auf seinen internen Zustand.

;;; pre-method-type = object scheme-value ... -> scheme-value
;;; ERKLÄRUNG
;;; (<pre-method> obj arg1 ... argn) wendet die durch <pre-method>
;;; implementierte Methode von obj auf arg1 ... argn an.


;;; Implementierung eines Objekts

;;; - interner Zustand
;;; - Zuordnung von Nachrichten zu Methoden (method suite)
;;; - Symbole für Namen von Nachrichten







;;; Beispiel
(define lone-speaker
  (lambda (message)
    (case message
      ((say)
       (lambda (this stuff)
	 (display stuff)
	 (newline)))
      (else
       (make-no-method 'speaker message)))))

;;; no-method muss von Methoden unterscheidbar sein.
(define-struct no-method (class message))










;;; SIGNATUR
;;; get-method : object symbol -> pre-method-type
;;; ERKLÄRUNG
;;; (get-method obj message) extrahiert die (Prä-) Methode message aus obj.
;;; DEFINITION
(define get-method
  (lambda (obj message)
    (obj message)))















;;; SIGNATUR
;;; send : object symbol scheme-value ... -> scheme-value
;;; ERKLÄRUNG
;;; (send obj message arg ...) sendet die Nachricht message mit
;;; Argumenten arg ... and obj; ruft die Methode message auf.
;;; DEFINITION
(define send
  (lambda (obj message . args)
    (let ((pre-method (get-method obj message)))
      (if (no-method? pre-method)
	  (error "no method"
		 (no-method-message pre-method)
		 'of
		 (no-method-class pre-method))
	  (apply pre-method obj args)))))








;;; Exkurs: Funktionen mit variabler Anzahl von Argumenten

;;; Eine Funktion mit n festen und beliebig vielen weiteren Argumenten:
;;; ((lambda (x1 ... xn . x) e) v1 ... vn w1 ... wm)
;;; ===>
;;; e [ x1 -> v1, ..., xn -> vn, x -> (list w1 ... wm)]

;;; Eine Funktion mit beliebig vielen Argumenten:
;;; ((lambda x e) w1 ... wm)
;;; ===>
;;; e [ x -> (list w1 ... wm)]

;;; Anwenden einer Funktion auf eine Liste von Argumenten:
;;; (apply f v1 ... vn (list w1 ... wm))
;;; ===>
;;; (f v1 ... vn w1 ... wm)







;;; Beispiele
(send lone-speaker 'say
      '(the quick brown fox jumped over the lazy dogs tail))
(send lone-speaker 'say '(i-m a poor lonesome cowboy))
(send lone-speaker 'say '(expelliarmo))
'(send lone-speaker 'cough)

















;;; K12.2 Klassen

;;; Meist werden mehrere Objekte mit ähnlichen Fähigkeiten und
;;; Verantwortlichkeiten benötigt. Sie werden zu einer KLASSE
;;; zusammengefasst. 

;;; Implementierung: Eine Klasse ist eine Funktion, die als Parameter
;;; objektspezifische Werte nimmt und ein entsprechendes Objekt liefert.















;;; Beispiel: Eine Klasse für speaker
(define make-speaker
  (lambda (name)
    (lambda (message)
      (case message
	((say)
	 (lambda (this stuff)
	   (display stuff)
	   (newline)))
	((update-name)
	 (lambda (this f)
	   (let ((new-name (f name)))
	     (if (eq? new-name name)
		 new-name
		 (begin
		   (set! name (f name))
		   (send this 'say (list 'my 'name 'is name))
		   name)))))
	(else
	 (make-no-method 'speaker message))))))



;;; Beispiele:
(define max (make-speaker 'max))
(define moritz (make-speaker 'max))

(send max 'update-name (lambda (x) x))
(send moritz 'update-name (lambda (x) 'moritz))

















;;; Bemerkungen

;;; "name" ist eine INSTANZVARIABLE oder ATTRIBUT des Objekts. Sie ist
;;; Teil der Identität des Objekts,
;;; d.h. jedes Objekt hat einen eigenständigen Wert für "name".

;;; Der Name einer Klasse (hier 'speaker) dient oft als Typ der
;;; Objekte dieser Klasse. Sie sind dadurch gekennzeichnet, dass sie
;;; alle genau die gleichen Methoden besitzen.

;;; Das heisst, der Typ 'speaker steht für alle diejenigen Objekte,
;;; die die Nachrichten 'say und 'update-name verstehen.

;;;  ==> Objekt-basierte Programmierung









;;; Werte für alle Objekte einer Klasse
(define make-counted-speaker
  (let ((count 0))
    (lambda (name)
      (set! count (+ count 1))
      (lambda (message)
	(case message
	  ((say)
	   (lambda (this stuff)
	     (display stuff)
	     (newline)))
	  ((how-many)
	   (lambda (this)
	     (send this 'say (list 'there 'are count 'of 'us))))
	  (else
	   (make-no-method 'speaker message)))))))

;;; "count" ist eine KLASSENVARIABLE (statische Variable). Sie wird
;;; von allen Objekten der Klasse gemeinsam benutzt.




;;; Beispiele
'(
  (define verona (make-counted-speaker 'verona-feldbusch))
  (define gerry (make-counted-speaker 'gerry-halliwell))
  (send gerry 'how-many)
  (send verona 'how-many)
)

;;; Analog sind auch KLASSENMETHODEN möglich. Siehe Übung.














;;; K12.3 Vererbung (Inheritance)

;;; Manche Objekte haben Fähigkeiten, die über diejenigen einer
;;; existierenden Klasse hinausgehen. Die entsprechenden Objekte
;;; werden zu einer neuen Klasse zusammengefasst. Sie
;;; ERBEN die Fähigkeiten aller Objekte einer existierenden Klasse.
;;; Dabei können NEUE METHODEN HINZUGEFÜGT   (extension)
;;; und/oder     ALTE METHODEN ÜBERSCHRIEBEN (overriding)
;;; werden.

;;; Die so entstehende neue, erweiterte Klasse ist eine UNTERKLASSE
;;; (subclass) der bereits existierenden Klasse (der OBERKLASSE,
;;; superclass). 










;;; Beispiel:
;;; Ein lecturer ist ein speaker mit einer neuen Methode 'lecture.
;;; Dh. lecturer ist Unterklasse von speaker.

(define make-lecturer
  (lambda (name)
    (let ((super (make-speaker name)))
      (lambda (message)
	(case message
	  ((lecture)
	   (lambda (this stuff)
	     (send this 'say (append stuff '(... by induction)))))
	  (else
	   (get-method super message)))))))

;;; DELEGATION:
;;; Nachrichten, die nicht erkannt werden, werden weitergereicht.

(define doc-holiday (make-lecturer 'doc-holiday))
(send doc-holiday 'lecture '(whisky is pretty strong stuff))



;;; Beispiel: Ein arrogant-lecturer ist ein lecturer, dessen Methode
;;; 'say umdefiniert ist. 

(define make-arrogant-lecturer
  (lambda (name)
    (let ((super (make-lecturer name)))
      (lambda (message)
	(case message
	  ((say)
	   (lambda (this stuff)
	     (send super 'say (append '(it is obvious that)
				      stuff))))
	  (else
	   (get-method super message)))))))

;;; - arrogant-lecturer ist Unterklasse von lecturer.
;;; - Die Methode 'say wird ÜBERSCHRIEBEN (method override).
;;; - Zugriff auf Methoden von lecturer über (send super ...).





;;; Beispiele
(define sundance-kid (make-arrogant-lecturer 'sundance-kid))
(send sundance-kid 'say '(the whisky is fine today))
(send sundance-kid 'lecture '(billy must be killed))

(send sundance-kid 'update-name (lambda (x) 'nobody))

















;;; SPÄTE BINDUNG

;;; Im Rumpf der Methode 'lecture von sundance-kid wird die Methode
;;; 'say aufgerufen. Damit wird NICHT die Methode 'say der Superklasse
;;; speaker aufgerufen, sondern die Methode 'say von
;;; arrogant-lecturer, obwohl die Existenz dieser Methode zum Zeitpunkt der
;;; Definition von lecturer noch nicht bekannt war.
;;; Diese Eigenart heisst SPÄTE (oder DYNAMISCHE) BINDUNG, da die
;;; Bedeutung eines Methodenaufrufs von der tatsächlichen Klasse des
;;; Objekts abhängt und nicht zur Zeit der Definition der Klasse lecturer
;;; festgelegt wird.

;;; Im Gegensatz dazu unterliegen die Namen der Instanzvariablen der
;;; FRÜHEN (oder LEXIKALISCHEN oder STATISCHEN) BINDUNG, da der
;;; Zugriff auf sie bereits zur Zeit der Definition der Klasse
;;; festgelegt wird. Ihr Geltungsbereich ist der Rumpf des lambda/let,
;;; das sie definiert.






;;; VERERBUNG und SUBTYPEN

;;; Vererbung dient der Wiederverwendung von Code und Verhalten.
;;; Zusätzlich stehen die Typen von Unterklasse und Klasse oft in
;;; einer sinnvollen Beziehung.

;;; Wenn A Unterklasse von B ist, so versteht jedes A-Objekt sämtliche 
;;; Nachrichten, die auch B-Objekte verstehen. Oft kann daher an jeder
;;; Stelle, wo ein B-Objekt erwartet wird, ein A-Objekt eingesetzt 
;;; werden. Diese Eigenschaft heisst SUBSUMPTION. 

;;; Wenn Klassennamen als Typen interpretiert werden, so ist der Typ A
;;; ein SUBTYP vom Typ B. 
;;; Schreibweise hierfür:  A <: B 

;;; Beispiele:
;;; - jeder lecturer versteht die Methode 'say von speaker
;;; - jeder arrogant-lecturer versteht die Methode 'lecture von lecturer
;;; - jeder arrogant-lecturer versteht die Methode 'say von speaker
;;; Also: arrogant-lecturer <: lecturer <: speaker



;;; K12.4 Mixins

;;; Oft ist die Festlegung einer bestimmten Oberklasse, von der Methoden
;;; geerbt werden, zu starr.

;;; Ein MIXIN ist eine Klassendefinition, in der über die Superklasse
;;; abstrahiert wird. Falls Klassen durch Mixins definiert sind, so
;;; können Fähigkeiten aus mehreren Klassen geerbt werden.















;;; Beispiel: Ein Mixin für Sänger 
;;; Anwendbar auf alle Klassen, deren Objekte 'say verstehen.
(define make-singer
  (lambda (super-class)
    (lambda (name)
      (let ((super (super-class name)))
	(lambda (message)
	  (case message
	    ((sing)
	     (lambda (this)
	       (display '(tra-la-la-la-la))
	       (newline)))
	    ((say)
	     (lambda (this stuff)
	       (send super 'say (append stuff '(tra-la-la-la-la)))))
	    (else
	     (get-method super message))))))))






;;; Beispiele
(define make-singing-speaker
  (make-singer make-speaker))
(define make-singing-lecturer
  (make-singer make-lecturer))

(define madonna (make-singing-lecturer 'madonna))
(send madonna 'sing)
(send madonna 'say '(now I-m gonna be an english upper class mother!))














(define make-eater              ;; Ein Mixin für Esser
  (lambda (super-class)
    (lambda (name)
      (let ((super (super-class name)))
	(lambda (message)
	  (case message
	    ((eat)
	     (lambda (this food)
	       (case food
		 ((orange banana pineapple)
		  (send this 'say '(yummy yummy)))
		 ((pal)
		  (send this 'say '(yuck dog food)))
		 (else
		  (send this 'say (list 'i 'really 'enjoyed food
                                        'but 'no 'more 'please))))))
	    ((say)
	     (lambda (this stuff)
	       (send super 'say (append '(schluerf) stuff '(schmatz)))))
	    (else
	     (get-method super message))))))))


;;; Beispiele
(define make-eating-singing-speaker
  (make-eater make-singing-speaker))
(define make-singing-eating-speaker
  (make-singer (make-eater make-speaker)))

(define otto (make-eating-singing-speaker 'otto))
(define charly (make-singing-eating-speaker 'charly))

(send otto 'sing)
(send otto 'say '(wir bauen einen hamsterkaefig aus papis stereoboxen))
(send otto 'eat 'pal)

(send charly 'sing)
(send charly 'say '(ugh ugh ugh))
(send charly 'eat 'banana)







;;; K12.5 Alternative Implementierung von Methodensuiten

;;; Mit der bisherigen Implementierung durch Funktionen ist das
;;; Verhalten eines Objekts (im Wesentlichen) nach seiner Erzeugung
;;; festgelegt. Auch dies ist manchmal zu starr.

;;; Ziel: Nachträgliche Änderung des Verhaltens eines Objekts zur
;;; Laufzeit des Programms.

;;; NB: Diese Implementierung (abzüglich der dynamischen Veränderung)
;;; ist die übliche Implementierung von Methodensuiten.












;;; Implementierung
;;; method-suite = pair(symbol,list(pair(symbol,pre-method-type)))
;;;              = pair(method-suite,list(pair(symbol,pre-method-type)))

(define make-alt-speaker
  (lambda (name)
    (list '*method-suite*
	  (cons 'say
		(lambda (this stuff)
		  (display stuff)
		  (newline)))
	  (cons 'update-name
		(lambda (this f)
		  (let ((new-name (f name)))
		    (if (eq? new-name name)
			new-name
			(begin
			  (set! name (f name))
			  (alt-send this 'say (list 'my 'name 'is name))
			  name))))))))



;;; Zugriff auf Methoden (vgl. get-method)
(define get-alt-method
  (lambda (obj message)
    (let ((name&pre-method (assoc message (cdr obj))))
      (if name&pre-method
	  (cdr name&pre-method)
          (let ((super (car obj)))
            (and (pair? super)
                 (get-alt-method super message)))))))














;;; Methodenaufruf (vgl. send)
(define alt-send
  (lambda (obj message . args)
    (let ((pre-method (get-alt-method obj message)))
      (if pre-method
	  (apply pre-method obj args)
	  (error "no method"
		 message)))))















;;; Beispiel:
;;; Verwandle einen speaker in einen Frosch
(define turn-into-frog
  (lambda (speaker)
    (alt-send speaker 'update-name (lambda (x) 'frog))
    (update-method speaker
		   'say
		   (lambda (this stuff)
		     (display '(quak quak))
		     (newline)))))

;;; Dynamisches Überschreiben einer Methode (method update)
(define update-method
  (lambda (obj message pre-method)
    (set-cdr! obj (cons (cons message pre-method) (cdr obj)))))








;;; Ein Opfer...
(define prince (make-alt-speaker 'prince))

(alt-send prince 'say '(I-m a prince and i-m looking for a princess))
(turn-into-frog prince)
(alt-send prince 'say '(I-m a prince and i-m looking for a princess))

















;;; Implementierung von Vererbung mit der alternativen Implementierung
;;; von Methodensuiten
(define make-alt-lecturer
  (lambda (name)
    (let ((super (make-alt-speaker name)))
      (list super
	    (cons 'lecture
		  (lambda (this stuff)
		    (alt-send this 'say (append stuff
                                                '(... by induction)))))))))

;;; Beispiel:
(define descartes
  (make-alt-lecturer 'descartes))
(alt-send descartes 'lecture '(i think therefore i am))