;; Die Unicolorsität Tübingen

;;; Objektsystem aus der Vorlesung

;; Objekte sind Prozeduren, die Methoden zurückgeben

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

(define method? procedure?)

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

;;; Personen, Orte und Dinge sind Objekte mit Namen

(define make-named-object
  (lambda (name)
    (lambda (message) 
      (cond ((eq? message 'name) (lambda (self) name))
	    (else 'no-method)))))

;;; Personen und Dinge sind beweglich

(define make-mobile-object
  (lambda (name location)
    (let ((named-obj (make-named-object name)))
      (lambda (message)
	(cond ((eq? message 'place)    (lambda (self) location))
	      ((eq? message 'install)
	       (lambda (self)
		 (send location 'add-thing self)))
	      ;; Die folgende Methode ist nur für die interne Verwendung
	      ;; gedacht.  Siehe stattdessen CHANGE-PLACE.
	      ((eq? message 'set-place)
	       (lambda (self new-place)
		 (set! location new-place)
		 'place-set))
	      (else (get-method named-obj message)))))))

(define make&install-mobile-object
  (lambda (name place)
    (let ((mobile-obj (make-mobile-object name place)))
      (send mobile-obj 'install)
      mobile-obj)))

;;; Ein Ding kann einen Eigentümer haben

(define make-thing
  (lambda (name birthplace)
    (let ((owner     'nobody)
	  (mobile-obj (make-mobile-object name birthplace)))
      (lambda (message)
	(cond ((eq? message 'owner)    (lambda (self) owner))
	      ((eq? message 'ownable?) (lambda (self) #t))
	      ((eq? message 'owned?)
	       (lambda (self)
		 (not (eq? owner 'nobody))))
	      ;; Die folgende Methode ist nur für die interne Verwendung
	      ;; gedacht.  Siehe stattdessen TAKE und LOSE.
	      ((eq? message 'set-owner)
	       (lambda (self new-owner)
		 (set! owner new-owner)
		 'owner-set))
	      (else (get-method mobile-obj message)))))))

(define make&install-thing
  (lambda (name birthplace)	
    (let ((thing  (make-thing name birthplace)))
      (send thing 'install)
      thing)))

;;; Orte

(define make-place
  (lambda (name)
    (let ((neighbor-map '())		
	  (things       '())
	  (named-obj (make-named-object name)))
      (lambda (message)
	(cond ((eq? message 'things) (lambda (self) things))
	      ((eq? message 'neighbors)
	       (lambda (self) (map cdr neighbor-map)))
	      ((eq? message 'exits)
	       (lambda (self) (map car neighbor-map)))
	      ((eq? message 'neighbor-towards)
	       (lambda (self direction)
		 (let ((places (assq direction neighbor-map)))
		   (if places
		       (cdr places)
		       #f))))
	      ((eq? message 'add-neighbor)
	       (lambda (self direction new-neighbor)
		 (cond ((assq direction neighbor-map)
			(display-message (list "Direction already assigned"
					       direction name))
			#f)
		       (else
			(set! neighbor-map
			      (cons (cons direction new-neighbor) neighbor-map))
			#t))))
	      ((eq? message 'accept-person?)
	       (lambda (self person)
		 #t))
	      ;; Die folgenden beiden Methoden sind nur für die
	      ;; interne Verwendung gedacht.  Siehe stattdessen
	      ;; CHANGE-PLACE.
	      ((eq? message 'add-thing)
	       (lambda (self new-thing)
		 (cond ((memq new-thing things)
			(display-message (list (send new-thing 'name)
					       "is already at" name))
			#f)
		       (else (set! things (cons new-thing things))
			     #t))))
	      ((eq? message 'del-thing)
	       (lambda (self thing)
		 (cond ((not (memq thing things))
			(display-message (list (send thing 'name)
					       "is not at" name))
			#f)
		       (else (set! things (delq thing things))
			     #t))))

	      (else (get-method named-obj message)))))))

;;; Personen

(define make-person
  (lambda (name birthplace laziness)
    (let ((possessions '())
	  (mobile-obj  (make-mobile-object name birthplace)))
      (lambda (message)
	(cond ((eq? message 'person?)     (lambda (self) #t))
	      ((eq? message 'possessions) (lambda (self) possessions))
	      ((eq? message 'list-possessions)
	       (lambda (self)
		 (send self 'say
		      (cons "I have"
			    (if (null? possessions)
				'("nothing")
				(map (lambda (p) (send p 'name))
				     possessions))))
		 possessions))
	      ((eq? message 'say)
	       (lambda (self list-of-stuff)
		 (display-message
		  (append (list "At" (send (send self 'place) 'name)
				":"  name "says --")
			  (if (null? list-of-stuff)
			      '("Oh, nevermind.")
			      list-of-stuff)))
		 'said))
	      ((eq? message 'have-fit)
	       (lambda (self)
		 (send self 'say '("Yaaaah! I am upset!"))
		 'I-feel-better-now))
	      ((eq? message 'look-around)
	       (lambda (self)
		 (let ((other-things
			(map (lambda (thing) (send thing 'name))
			     (delq self
				   (send (send self 'place)
					'things)))))
		   (send self 'say (cons "I see" (if (null? other-things)
						    '("nothing")
						    other-things)))
		   other-things)))

	      ((eq? message 'take)
	       (lambda (self thing)
		 (cond ((memq thing possessions)
			(send self 'say
			     (list "I already have" (send thing 'name)))
			#t)
		       ((and (let ((things-at-place (send (send self 'place) 'things)))
			       (memq thing things-at-place))
			     (is-a thing 'ownable?))
			(if (send thing 'owned?)
			    (let ((owner (send thing 'owner)))
			      (send owner 'lose thing)
			      (send owner 'have-fit))
			    'unowned)

			(send thing 'set-owner self)
			(set! possessions (cons thing possessions))
			(send self 'say
			     (list "I take" (send thing 'name)))
			#t)
		       (else
			(display-message
			 (list "You cannot take" (send thing 'name)))
			#f))))
	      ((eq? message 'lose)
	       (lambda (self thing)
		 (cond ((eq? self (send thing 'owner))
			(set! possessions (delq thing possessions))
			(send thing 'set-owner 'nobody)
			(send self 'say
			     (list "I lose" (send thing 'name)))
			#t)
		       (else
			(display-message (list name "does not own"
					       (send thing 'name)))
			#f))))
	      ((eq? message 'move)
	       (lambda (self)
		 ;; (random laziness) liefert eine (mehr oder weniger)
		 ;; zufällige Zahl zwischen 0 und LAZINESS-1
		 (cond ((= (random laziness) 0)
			(send self 'act)
			#t))))
	      ((eq? message 'act)
	       (lambda (self)
		 (let ((new-place (random-neighbor (send self 'place))))
		   (if new-place
		       (send self 'move-to new-place)
		       #f))))

	      ((eq? message 'move-to)
	       (lambda (self new-place)
		 (let ((old-place (send self 'place)))
		   (cond ((eq? new-place old-place)
			  (display-message (list name "is already at"
						 (send new-place 'name)))
			  #f)
			 ((send new-place 'accept-person? self)
			  (change-place self new-place)
			  (for-each (lambda (p) (change-place p new-place))
				    possessions)
			  (display-message
			   (list name "moves from" (send old-place 'name)
				 "to"         (send new-place 'name)))
			  (greet-people self (other-people-at-place self new-place))
			  #t)
			 (else
			  (display-message (list name "can't move to"
						 (send new-place 'name))))))))
	      ((eq? message 'go)
	       (lambda (self direction)
		 (let ((old-place (send self 'place)))
		   (let ((new-place (send old-place 'neighbor-towards direction)))
		     (cond (new-place
			    (send self 'move-to new-place))
			   (else
			    (display-message (list "You cannot go" direction
						   "from" (send old-place 'name)))
			    #f))))))
	      ((eq? message 'install)
	       (lambda (self)
		 (add-to-clock-list self)
		 ((get-method mobile-obj 'install) self)))
	      (else (get-method mobile-obj message)))))))
  
(define make&install-person
  (lambda (name birthplace laziness)
    (let ((person (make-person name birthplace laziness)))
      (send person 'install)
      person)))

;;; Ein Assi ist auch eine Person

(define make-assi
  (lambda (name birthplace laziness)
    (let ((person (make-person name birthplace laziness)))
      (lambda (message)
	(cond ((eq? message 'act)
	       (lambda (self)
		 (let ((others (other-people-at-place self (send self 'place))))
		   (if (not (null? others))
		       (send self 'eat-person (pick-random others))
		       ((get-method person 'act) self)))))
	      ((eq? message 'eat-person)
	       (lambda (self person)
		 (send self 'say
		      (list "Growl... I'm going to eat you,"
			    (send person 'name)))
		 (go-to-heaven person)
		 (send self 'say
		      (list "Chomp chomp." (send person 'name)
			    "tastes yummy!"))
		 '*burp*))
	      (else (get-method person message)))))))

(define make&install-assi
  (lambda (name birthplace laziness)
    (let ((assi  (make-assi name birthplace laziness)))
      (send assi 'install)
      assi)))

(define go-to-heaven
  (lambda (person)
    (for-each (lambda (item) (send person 'lose item))
	      (send person 'possessions))
    (send person 'say
	 '("
                   Dulce et decorum est 
                   pro computatore mori!"
	   ))
    (send person 'move-to heaven)
    (remove-from-clock-list person)
    'game-over-for-you-dude))

(define heaven (make-place 'heaven))

;;; Uhr

(define *clock-list* '())
(define *the-time* 0)

(define (initialize-clock-list)
  (set! *clock-list* '())
  'initialized)

(define (add-to-clock-list person)
  (set! *clock-list* (cons person *clock-list*))
  'added)

(define (remove-from-clock-list person)
  (set! *clock-list* (delq person *clock-list*))
  'removed)

(define (clock)
  (display "---Tick---")
  (newline)
  (set! *the-time* (+ *the-time* 1))
  (for-each (lambda (person) (send person 'move))
	    *clock-list*)
  'tick-tock)
	     

(define (current-time)
  *the-time*)

(define (run-clock n)
  (cond ((zero? n) 'done)
	(else (clock)
	      (run-clock (- n 1)))))

;;; Hilfsprozeduren

(define is-a
  (lambda (object property)
    (let ((method (get-method object property)))
      (if (method? method)
	  (send object property)
	  #f))))

;; CHANGE-PLACE muß sowohl mit mobilen Objekten als auch mit Orten
;; kommunizieren und ist darum keine Methode.

(define change-place
  (lambda (mobile-object new-place)
    (let ((old-place (send mobile-object 'place)))
      (send mobile-object 'set-place new-place)
      (send old-place 'del-thing mobile-object))
    (send new-place 'add-thing mobile-object)
    'place-changed))

(define other-people-at-place
  (lambda (person place)
    (filter (lambda (object)
	      (if (not (eq? object person))
		  (is-a object 'person?)
		  #f))
	    (send place 'things))))

(define greet-people
  (lambda (person people)
    (if (not (null? people))
	(send person 'say
	     (cons "Hi"
		   (map (lambda (p) (send p 'name))
			people)))
	'sure-is-lonely-in-here)))

(define display-message
  (lambda (list-of-stuff)
    (for-each (lambda (s) (display s) (display " "))
	      list-of-stuff)
    (newline)))

(define random-neighbor
  (lambda (place)
    (pick-random (send place 'neighbors))))

;; FILTER liefert eine Liste der Elemente von LST, für die PREDICATE #t
;; liefert.
(define filter
  (lambda (predicate lst)
    (cond ((null? lst) '())
	  ((predicate (car lst))
	   (cons (car lst) (filter predicate (cdr lst))))
	  (else (filter predicate (cdr lst))))))

;; (random k) liefert eine (mehr oder weniger) zufällige Zahl zwischen
;; 0 und k-1

(define pick-random
  (lambda (lst)
    (if (null? lst)
	#f
	(list-ref lst (random (length lst))))))

(define delq
  (lambda (item lst)
    (cond ((null? lst) '())
	  ((eq? item (car lst)) (delq item (cdr lst)))
	  (else (cons (car lst) (delq item (cdr lst)))))))

;; Dieser Aufruf sorgt dafür, daß bei jedem Programmstart die gleichen
;; Zufallszahlen von RANDOM generiert werden.

(random-seed 2342)

;; Studierendenausweise

(define make&install-studenting-card
  (lambda (name birthplace id)
    (let ((card (make-studenting-card name birthplace id)))
      (send card 'install)
      card)))

(define make-studenting-card
  (lambda (name birthplace idnumber)
    (let ((id idnumber)
	  (thing (make-thing name birthplace)))
      (lambda (message)
	(cond ((eq? message 'studenting-card?) (lambda (self) #t))
	      ((eq? message 'id) (lambda (self) id))
	      (else (get-method thing message)))))))

(define copy-studenting-card
  (lambda (card)
    (let ((name   (symbol-append 'copy-of- (send card 'name)))
	  (place  (send card 'place))
	  (id     (send card 'id)))
      (make&install-studenting-card name place id))))

;; SYMBOL-APPEND produziert ein neues Symbol, dessen Name aus der
;; Aneinanderhängung der Namen von SYMBOL-1 und SYMBOL-2 entsteht.
;; (symbol-append 'foo 'bar) => foobar

(define symbol-append
  (lambda (symbol-1 symbol-2)
    (string->symbol (string-append (symbol->string symbol-1)
				   (symbol->string symbol-2)))))

;; Die Welt der Unicolorsität

(initialize-clock-list)

;; Orte an der Uni

(define solarium   (make-place 'solarium))
(define mike-office (make-place 'mike-office))
(define herb-office (make-place 'herb-office))
(define wsi-ground-floor-hallway  (make-place 'wsi-ground-floor-hallway))
(define wsi-first-floor-hallway  (make-place 'wsi-first-floor-hallway))
(define wsi-second-floor-hallway  (make-place 'wsi-second-floor-hallway))
(define wsi-library (make-place 'wsi-library))
(define s1 (make-place 's1))
(define mensa  (make-place 'mensa))
(define n3 (make-place 'n3))
(define gesternstelle-basement (make-place' gesternstelle-basement))
(define gesternstelle-bus-stop (make-place 'gesternstelle-bus-stop))
(define sand-bus-stop (make-place 'sand-bus-stop))
(define bus-gesternstelle->sand (make-place 'bus-gesternstelle->sand))
(define bus-sand->gesternstelle (make-place 'bus-sand->gesternstelle))

;; "Einbahnstraßen"

(define (can-go from direction to)
  (send from 'add-neighbor direction to))

;; Wege, die sich in zwei Richtungen begehen lassen

(define (can-go-both-ways from direction reverse-direction to)
  (can-go from direction to)
  (can-go to reverse-direction from))

(can-go-both-ways wsi-first-floor-hallway 'south 'north mike-office)
(can-go-both-ways wsi-first-floor-hallway 'east 'west herb-office)
(can-go-both-ways wsi-ground-floor-hallway 'up 'down wsi-first-floor-hallway)
(can-go-both-ways wsi-first-floor-hallway 'up 'down wsi-second-floor-hallway)
(can-go-both-ways wsi-second-floor-hallway 'south 'north solarium)
(can-go-both-ways wsi-ground-floor-hallway 'south 'north wsi-library)

(can-go-both-ways sand-bus-stop 'south 'north wsi-ground-floor-hallway)
(can-go bus-gesternstelle->sand 'east sand-bus-stop)
(can-go sand-bus-stop 'west bus-sand->gesternstelle)

(can-go bus-sand->gesternstelle 'east gesternstelle-bus-stop)
(can-go gesternstelle-bus-stop 'west bus-gesternstelle->sand)
(can-go-both-ways gesternstelle-bus-stop 'north 'south mensa)

(can-go-both-ways mensa 'north 'south n3)
(can-go-both-ways n3 'down 'up gesternstelle-basement)

(can-go-both-ways gesternstelle-basement 'north 'south s1)

;; Menschen und andere Wesen

(define herb (make&install-person 'herb herb-office 3))
(define joe-student (make&install-person 'joe-student s1 2))

(define mike (make&install-assi 'mike mike-office 1))

(define mike-card
  (make&install-studenting-card 'mike-card mike-office 2975467))
(define joe-student-card
  (make&install-studenting-card 'joe-student-card s1 112233))

;; Eigene Definitionen und Spielzüge: