;;;
;;; MIT 6.001                                    Fall, 2002
;;; PROJECT 2
;;;
;;; This file defines object types for use in our simulation
;;; world.  The full world is created in setup.scm.

;;--------------------
;; named-object
;; 
;; Named objects are the basic underlying object type in our
;; system. For example, persons, places, and things will all 
;; be kinds of (inherit from) named objects.
;;
;; Behavior (messages) supported by all named objects:
;;  - Answers #T to the question NAMED-OBJECT?
;;  - Has a NAME that it can return
;;  - Handles an INSTALL message
;;  - Handles a  DESTROY message

(define (make-named-object name . characteristics) ; symbol, string ->  named-object
  (let ((root-part (make-root-object)))
    (lambda (message)
      (case message
	((NAMED-OBJECT?) (lambda (self) #T))
	((NAME) (lambda (self) name))
	((CHARACTERISTICS) (lambda (self) characteristics))
	((INSTALL) (lambda (self) 'INSTALLED))
	((DESTROY) (lambda (self) 'DESTROYED))
	(else (find-method message root-part))))))

(define (create-named-object name characteristics)
  (create make-named-object name characteristics))

(define (names-of objects)
  ;; Given a list of objects, returns a list of their names.
  (map (lambda (x) (ask x 'NAME)) objects))


;;--------------------
;; container
;;
;; A container holds THINGS.  
;; 
;; This class is not really meant as a "stand-alone" object class;
;; rather, it is expected that other classes will inherit from the
;; container class in order to be able to contain things.
     
(define (make-container)		; void -> container
  (let ((root-part (make-root-object))
	(things '()))			; a list of THING objects in container
    (lambda (message)
      (case message
	((CONTAINER?) (lambda (self) #T))
	((THINGS) (lambda (self) things))
	((HAVE-THING?)
	 (lambda (self thing)		; container, thing -> boolean
	   (not (null? (memq thing things)))))
	((ADD-THING)
	 (lambda (self new-thing)
	   (if (not (ask self 'HAVE-THING? new-thing))
	       (set! things (cons new-thing things)))
	   'DONE))
	((DEL-THING)
	 (lambda (self thing)
	   (set! things (delq thing things))
	   'DONE))
	(else (find-method message root-part))))))


;;--------------------
;; thing
;;
;; A thing is a named-object that has a LOCATION
;;
;; Note that there is a non-trivial installer here.  What does it do?

(define (make-thing name location characteristics)  
  ;; symbol, location, characteristics -> thing
  (let ((named-object-part (make-named-object name characteristics)))
    (lambda (message)
      (case message
	((THING?) (lambda (self) #T))
	((LOCATION) (lambda (self) location))
	((INSTALL)
	 (lambda (self)			; Install: synchronize thing and place
	   (ask (ask self 'LOCATION) 'ADD-THING self)
	   (delegate named-object-part self 'INSTALL)))
	((DESTROY)
	 (lambda (self)			; Destroy: remove from place
	   (ask (ask self 'LOCATION) 'DEL-THING self)
	   (delegate named-object-part self 'DESTROY)))
	((EMIT)
	 (lambda (self text)		; Output some text
	   (ask screen 'TELL-ROOM (ask self 'LOCATION)
		(append (list "At" (ask (ask self 'LOCATION) 'NAME))
			text))))
	(else (get-method message named-object-part))))))

(define (create-thing name location characteristics)
  (create make-thing name location characteristics))

;;--------------------
;; mobile-thing
;;
;; A mobile thing is a thing that has a LOCATION that can change.

(define (make-mobile-thing name location characteristics)
  ;; symbol, location, string -> mobile-thing
  (let ((thing-part (make-thing name location characteristics)))
    (lambda (message)
      (case message
	((MOBILE-THING?) (lambda (self) #T))
	((LOCATION)			; This shadows message to thing-part!
	 (lambda (self) location))
	((CHANGE-LOCATION)
	 (lambda (self new-location)
	   (ask location 'DEL-THING self)
	   (ask new-location 'ADD-THING self)
	   (set! location new-location)))
	((ENTER-ROOM)
	 (lambda (self exit) #t))
	((LEAVE-ROOM)
	 (lambda (self exit) #t))
	((CREATION-SITE)
	 (lambda (self)
	   (delegate thing-part self 'location)))
	(else (get-method message thing-part))))))

(define (create-mobile-thing name location characteristics)
  (create make-mobile-thing name location characteristics))

;;--------------------
;; place
;;
;; A place is a container (so things may be in the place).
;;
;; A place has EXITS, which are passages from one place
;; to another.  One can retrieve all of the exits of a 
;; place, or an exit in a given direction from place. 
     
(define (make-place name characteristics) ; symbol, string -> place
  (let ((named-obj-part (make-named-object name characteristics))
	(container-part (make-container))
	(exits '()))			; a list of exits
    (lambda (message)
      (case message
	((PLACE?) (lambda (self) #T))
	((EXITS) (lambda (self) exits))
	((EXIT-TOWARDS)
	 (lambda (self direction)	   
	   (let ((ex (find-exit-in-direction exits direction)))
	     (if (and ex (ask ex 'HIDDEN?))
		 #F
		 ex))))
	((ADD-EXIT)
	 (lambda (self exit)		; place, symbol -> exit | #f
	   (let ((direction (ask exit 'DIRECTION)))
	     (cond ((ask self 'EXIT-TOWARDS direction)
		    (error (list name "already has exit" direction)))
		   (else 
		    (set! exits (cons exit exits))
		    'DONE)))))
	(else
	 (find-method message container-part named-obj-part))))))

(define (create-place name characteristics)
  (create make-place name characteristics))

;;------------------------------------------------------------
;; exit
;;
;; An exit leads FROM one place TO another in some DIRECTION.

(define (make-exit from direction to lock-proc)
  ;; idea behind lock-proc is that if false, then exit
  ;; always open, if a procedure, try it to see if it opens lock
  (let ((named-object-part (make-named-object direction))
	(partner '())
	(hidden? (if (eq? lock-proc #f)
		     #f
		     #t))
	(locked? (if (eq? lock-proc #f)
		     #f
		     #t)))
    (lambda (message)
      (case message
	((EXIT?)        (lambda (self) #T))
	((FROM)         (lambda (self) from))
	((TO)           (lambda (self) to))
	((DIRECTION)    (lambda (self) direction))
	((HIDDEN?)      (lambda (self) hidden?))
	((PARTNER)      (lambda (self) partner))
	((SET-PARTNER)  (lambda (self p) (set! partner p)))
	((USE)
	 (lambda (self whom)
	   (if locked?
	       ;; check to see if can unlock
	       (begin (lock-proc self whom);; this applies unlock procedure to person
		      (if locked?
			  (ask screen 'TELL-ROOM (ask whom 'location)
			       (list (ask whom 'NAME)
				     "tries to move from"
				     (ask (ask whom 'LOCATION) 'NAME)
				     "to"
				     (ask to 'NAME)
				     "but"
				     (ask (ask whom 'location) 'name)
				     "is locked in direction"
				     direction))
			  (begin
			    (ask whom 'LEAVE-ROOM self)
			    (ask screen 'TELL-ROOM (ask whom 'location)
				 (list (ask whom 'NAME)
				       "moves from" 
				       (ask (ask whom 'LOCATION) 'NAME)
				       "to"
				       (ask to 'NAME)))
			    (ask whom 'CHANGE-LOCATION to)
			    (ask whom 'ENTER-ROOM (ask self 'PARTNER)))))
	       (begin
		 (ask whom 'LEAVE-ROOM self)
		 (ask screen 'TELL-ROOM (ask whom 'location)
		      (list (ask whom 'NAME)
			    "moves from" 
			    (ask (ask whom 'LOCATION) 'NAME)
			    "to"
			    (ask to 'NAME)))
		 (ask whom 'CHANGE-LOCATION to)
		 (ask whom 'ENTER-ROOM (ask self 'PARTNER))))))
	((CHANGE-STATE)
	 (lambda (self)
	   (set! locked? (not locked?))))
	((CHANGE-HIDDEN)
	 (lambda (self)
	   (set! hidden? #f)))
	((INSTALL)
	 (lambda (self)
	   (ask (ask self 'FROM) 'ADD-EXIT self)
	   (delegate named-object-part self 'INSTALL)))
	(else (get-method message named-object-part))))))

(define (create-exit from direction to backdir locked-to? locked-back?)
  (let ((out (create make-exit from direction to locked-to?))
	(back (create make-exit to backdir from locked-back?)))
    (ask out 'SET-PARTNER back)
    (ask back 'SET-PARTNER out)
    (cons out back)))

(define (find-exit-in-direction exits dir)
  ;; Given a list of exits, find one in the desired direction.
  (cond ((null? exits) #f)
	((eq? dir (ask (car exits) 'DIRECTION))
	 (car exits))
	(else (find-exit-in-direction (cdr exits) dir))))

(define (random-exit place)
  (pick-random (ask place 'EXITS)))

;;--------------------
;; person
;;
;; There are several kinds of person:  
;;   There are autonomous persons, including trolls, and there
;;   is the avatar of the user.  The foundation is here.
;;
;; A person can move around (is a mobile-thing),
;; and can hold things (is a container). A person responds to
;; a plethora of messages, including 'SAY to say something.
;;

(define (make-person name birthplace characteristics)
  (let ((mobile-thing-part (make-mobile-thing name birthplace characteristics))
	(container-part    (make-container))
	(health            3)
	(strength          1))
    (lambda (message)
      (case message
	((PERSON?) (lambda (self) #T))
	((STRENGTH) (lambda (self) strength))
	((HEALTH) (lambda (self) health))
	((SAY)
	 (lambda (self list-of-stuff)
	   (ask screen 'TELL-ROOM (ask self 'location)
		(append (list "At" (ask (ask self 'LOCATION) 'NAME)
			      (ask self 'NAME) "says --")
			list-of-stuff))
	   'SAID-AND-HEARD))
	((HAVE-FIT)
	 (lambda (self)
	   (ask self 'SAY '("Yaaaah! I am upset!"))
	   'I-feel-better-now))

	((PEOPLE-AROUND)		; other people in room...
	 (lambda (self)
	   (let* ((in-room (ask (ask self 'LOCATION) 'THINGS))
		  (people (filter (lambda (x) (is-a x 'PERSON?)) in-room)))
	     (delq self people))))

	((STUFF-AROUND)			; stuff (non people) in room...
	 (lambda (self)
	   (let* ((in-room (ask (ask self 'LOCATION) 'THINGS))
		  (stuff (filter (lambda (x) (not (is-a x 'PERSON?))) in-room)))
	     stuff)))
             
	((PEEK-AROUND)			; other people's stuff...
	 (lambda (self)
	   (let ((people (ask self 'PEOPLE-AROUND)))
	     (accumulate append '() (map (lambda (p) (ask p 'THINGS)) people)))))


	((TAKE)
	 (lambda (self thing)
	   (cond ((ask self 'HAVE-THING? thing)	; already have it
		  (ask self 'SAY (list "I am already carrying"
				       (ask thing 'NAME)))
		  #f)
		 ((or (is-a thing 'PERSON?)
		      (not (is-a thing 'MOBILE-THING?)))
		  (ask self 'SAY (list "I try but cannot take"
				       (ask thing 'NAME)))
		  #F)
		 (else
		  (let ((owner (ask thing 'LOCATION)))
		    (ask self 'SAY (list "I take" (ask thing 'NAME) 
					 "from" (ask owner 'NAME)))
		    (if (is-a owner 'PERSON?)
			(ask owner 'LOSE thing self)
			(ask thing 'CHANGE-LOCATION self))
		    thing)))))

	((LOSE)
	 (lambda (self thing lose-to)
	   (ask self 'SAY (list "I lose" (ask thing 'NAME)))
	   (ask self 'HAVE-FIT)
	   (ask thing 'CHANGE-LOCATION lose-to)))

	((DROP)
	 (lambda (self thing)
	   (ask self 'SAY (list "I drop" (ask thing 'NAME)
				"at" (ask (ask self 'LOCATION) 'NAME)))
	   (ask thing 'CHANGE-LOCATION (ask self 'LOCATION))))

	((EXAMINE)
	 (lambda (self thing)
	   (let ((properties (ask thing 'CHARACTERISTICS)))
	     (ask screen 'TELL-WORLD
		  (if properties
		      (append '("It is") properties)
		      '("It looks plain and ordinary."))))))

	((MOVE-TO)
	 ;; this is really an internal procedure that should be used by a person,
	 ;; and should not be called by top level, since it takes an actual place
	 ;; rather than a name as input
	 ;; it is here so we can set up the game, but we DO NOT recommend that
	 ;; you actually use it when playing the game
	 (lambda (self new-place)
	   (let ((old-place (ask self 'LOCATION))
		 (my-stuff (ask self 'THINGS)))
	     (define (greet-people person people)
	       (if (not (null? people))
		   (ask person 'SAY
			(cons "Hi"
			      (map (lambda (p) (ask p 'NAME))
				   people)))
		   'sure-is-lonely-in-here))
	     (cond ((eq? new-place old-place)
		    (ask screen 'TELL-WORLD (list name "is already at"
						  (ask new-place 'NAME)))
		    #F)
		   ((is-a new-place 'PLACE?)
		    (ask self 'CHANGE-LOCATION new-place)
		    (for-each
		     (lambda (p) (ask p 'CHANGE-LOCATION new-place))
		     my-stuff)
		    (ask screen 'TELL-ROOM (ask self 'location)
			 (list name "moves from" (ask old-place 'NAME)
			       "to" (ask new-place 'NAME)))
		    (greet-people self
				  (other-people-at-place self new-place))
		    #T)
		   (else
		    (ask screen 'TELL-WORLD
			 (list name "can't move to"
			       (ask new-place 'NAME)))
		    #F)))))

	((GO-EXIT)
	 (lambda (self exit)
	   (ask exit 'USE self)))

	((GO)
	 (lambda (self direction)	; person, symbol -> boolean
	   (let ((exit (ask (ask self 'LOCATION) 'EXIT-TOWARDS direction)))
	     (if (is-a exit 'EXIT?)
		 (ask self 'GO-EXIT exit)
		 (begin (ask screen 'TELL-ROOM (ask self 'LOCATION)
			     (list "No exit in" direction "direction"))
			#F)))))
	((SUFFER)
	 (lambda (self hits)
	   (ask self 'SAY (list "Ouch!" hits "hits is more than I want!"))
	   (set! health (- health hits))
	   (if (< health 0) (ask self 'DIE))
	   health))

	((DIE)				; depends on global variable "heaven"
	 (lambda (self)
	   (ask self 'SAY '("SHREEEEK!  I, uh, suddenly feel very faint..."))
	   (for-each (lambda (item) (ask self 'LOSE item (ask self 'LOCATION)))
		     (ask self 'THINGS))
	   (ask self 'DEATH-SCREAM)
	   (ask death-exit 'USE self)
	   'GAME-OVER-FOR-YOU-DUDE))

	((DEATH-SCREAM)
	 (lambda (self)
	   (ask screen 'TELL-WORLD
		'("An earth-shattering, soul-piercing scream is heard..."))))

	((ENTER-ROOM)
	 (lambda (self exit)		; person, place -> boolean
	   (let ((others (ask self 'PEOPLE-AROUND)))
	     (if (not (null? others))
		 (ask self 'SAY (cons "Hi" (names-of others)))))
	   #T))
            
	(else (find-method message mobile-thing-part container-part))))))


(define (other-people-at-place person place)
  (find-all-other place 'PERSON? person))

(define (create-person name birthplace)
  (create make-person name birthplace))

;;--------------------
;; autonomous-player
;;
;; activity determines maximum movement
;; miserly determines chance of picking stuff up

(define (make-autonomous-player name birthplace activity miserly characteristics)
  (let ((person-part (make-person name birthplace characteristics))
	(alibi-room 'nowhere)
	(alibi-possessions 'nothing)
	(alibi-witnesses 'nobody))
    (lambda (message)
      (case message
	((AUTONOMOUS-PLAYER?) (lambda (self) #T))
	((INSTALL) (lambda (self)
		     (ask clock 'ADD-CALLBACK
			  (make-clock-callback 'move-and-take-stuff self 
					       'MOVE-AND-TAKE-STUFF))
		     (delegate person-part self 'INSTALL)))
	((MOVE-AND-TAKE-STUFF)
	 (lambda (self)
	   ;; first move
	   (let loop ((moves (random-number activity)))
	     (if (= moves 0)
		 'done-moving
		 (begin
		   (ask self 'MOVE-SOMEWHERE)
		   (loop (- moves 1)))))
	   ;; then take stuff
	   (if (= (random miserly) 0)
	       (ask self 'TAKE-SOMETHING))
	   'done-for-this-tick))
	((DIE)
	 (lambda (self)
	   (ask clock 'REMOVE-CALLBACK self 'move-and-take-stuff)
	   (delegate person-part self 'DIE)))
	((MOVE-SOMEWHERE)
	 (lambda (self)
	   (let ((exit (random-exit (ask self 'LOCATION))))
	     (if (not (null? exit)) (ask self 'GO-EXIT exit)))))
	((TAKE-SOMETHING)
	 (lambda (self)
	   (let* ((stuff-in-room (ask self 'STUFF-AROUND))
		  (other-peoples-stuff (ask self 'PEEK-AROUND))
		  (pick-from (append stuff-in-room other-peoples-stuff)))
	     (if (not (null? pick-from))
		 (ask self 'TAKE (pick-random pick-from))
		 #F))))
	((DROP-SOMETHING)
	 (lambda (self)
	   (let ((things-i-have (ask self 'THINGS)))
	     (if (not (null? things-i-have))
		 (ask self 'LOSE (pick-random things-i-have) (ask self 'LOCATION))
		 #F))))
	((SAVE-STATE);; remember information for an alibi
	 (lambda (self)
	   (set! alibi-room (ask  (ask self 'LOCATION) 'NAME))
	   (let ((holdings (map (lambda (x) (ask x 'NAME)) (ask self 'THINGS)))
		 (other-people
		  (map (lambda (x) (ask x 'NAME)) 
		       (other-people-at-place self (ask self 'LOCATION)))))
	     (if (not (null? holdings))
		 (set! alibi-possessions holdings))
	     (if (not (null? other-people))
		 (set! alibi-witnesses  other-people)))
	   'ok))
	((ALIBI)
	 (lambda (self)
	   (if  (eq? alibi-room 'nowhere)
		(ask self 'SAY '("Has a murder been committed?"))
		(begin
		  (ask self 'SAY (list "Me?  I was in the" alibi-room))
		  (ask self 'SAY (list "I had in my possession:"
				       alibi-possessions))
		  (ask self 'SAY (list "Oh, and" alibi-witnesses 
				       "was in the room with me"))))
	   (list alibi-room alibi-possessions alibi-witnesses)))           
	(else (get-method message person-part))))))

(define (create-autonomous-player name birthplace activity miserly characteristics)
  (create make-autonomous-player name birthplace activity miserly characteristics))

;;--------------------
;; avatar
;;
;; The avatar of the user is also a person.

(define (make-avatar name birthplace murder-details characteristics) 
  (let ((person-part (make-person name birthplace characteristics))
	(crime-details murder-details)
	(count 0))
    (lambda (message)
      (case message
	((AVATAR?) (lambda (self) #T))

	((LOOK-AROUND)			; report on world around you
	 (lambda (self)
	   (let* ((place (ask self 'LOCATION))
		  (exits (ask place 'EXITS))
		  (other-people (ask self 'PEOPLE-AROUND))
		  (my-stuff (ask self 'THINGS))
		  (stuff (ask self 'STUFF-AROUND)))
	     (ask screen 'TELL-WORLD (list "You are in" (ask place 'NAME)))
	     (ask screen 'TELL-WORLD
                  (if (null? my-stuff)
                      '("Your are not holding anything.")
                      (append '("You are holding:") (names-of my-stuff))))
	     (ask screen 'TELL-WORLD
                  (if (null? stuff)
                      '("There is no stuff in the room.")
                      (append '("You see stuff in the room:") (names-of stuff))))
	     (ask screen 'TELL-WORLD
                  (if (null? other-people)
                      '("There are no other people around you.")
                      (append '("You see other people:") (names-of other-people))))
	     (ask screen 'TELL-WORLD
                  (if (not (null? exits))
                      (append '("The exits are in directions:")
			      (names-of (filter (lambda (ex) (not (ask ex 'hidden?)))
						exits)))
                      ;; heaven is only place with no exits
                      '("There are no exits... you are dead and gone to heaven!")))
	     'OK)))

	((GO)
	 (lambda (self direction)	; Shadows person's GO
	   (let ((success? (delegate person-part self 'GO direction)))
	     (if success? (ask clock 'TICK))
	     success?)))
	((GET)
	 (lambda (self tname)
	   (let ((objs (filter (lambda (x) (eq? (ask x 'name) tname))
			       (ask (ask self 'location) 'things))))
	     (if (null? objs)
		 (ask self 'say `(I do not see a ,tname here))
		 (ask self 'take (car objs))))))
	((TOSS)
	 (lambda (self tname)
	   (let ((objs (filter (lambda (x) (eq? (ask x 'name) tname))
			       (ask self 'things))))
	     (if (null? objs)
		 (ask self 'say `(I do not have a ,tname))
		 (ask self 'drop (car objs))))))
	((TAKE)
	 (lambda (self thing)
	   (let ((thing (delegate person-part self 'TAKE thing)))
	     (if (and (not (null? thing))
		      (eq? 'diploma (ask thing 'NAME)))
		 (ask self 'SAY '("   HURRRAY!!!!!!!!!!!!!"))))))

	((GUESS)
	 (lambda (self room weapon murderer)
	   (if ((crime-details 'CHECK) room weapon murderer)
	       (ask screen 'TELL-WORLD
		    (list "You got it right!! (This was guess number "
			  (+ 1 count) "by you)"))
	       (begin
		 (set! count (+ 1 count))
		 (display-message (list "Hm.. not quite.."))))))

	(else (get-method message person-part))))))

(define (create-avatar name birthplace murder-details characterstics) 
  (create make-avatar name birthplace  murder-details characterstics))


;;; A killer is a type of person

(define (make-killer name birthplace laziness miserly murder-details characteristics)
  (let ((person-part (make-autonomous-player name birthplace laziness
					     miserly characteristics))
	(*has-killed-someone* false)
	(crime-details murder-details))
    (lambda (message)
      (case message
	((KILLER?) (lambda (self) #T))
	((INSTALL) (lambda (self)
		     (ask clock 'ADD-CALLBACK
			  (make-clock-callback 'prepare-to-murder self 
					       'PREPARE-TO-MURDER))
		     (delegate person-part self 'INSTALL)))
	((PREPARE-TO-MURDER)
	 (lambda (self)
	   (if (not *has-killed-someone*)
	       (if (= (random laziness) 0) 
		   (let ((weapons-i-have  
			  (filter (lambda (possibility) (memq possibility *weapons*)) 
				  (ask self 'THINGS))))
		     (if (null? weapons-i-have)
			 (begin
			   ;; try to get a weapon if there is one
			   (let ((things-at-place (ask (ask self 'LOCATION) 'THINGS)))
			     (let ((possible-weapons  
				    (filter 
				     (lambda (possibility)
				       (memq possibility *weapons*)) 
				     things-at-place)))
			       (if (not (null? possible-weapons))
				   (ask self 'TAKE (pick-random possible-weapons))
				   (delegate person-part self
					     'move-and-take-stuff)))))
			 (let ((others (other-people-at-place self
							      (ask self 'LOCATION))))
			   ;; see if there other people there
			   (if (not (null? others))                        
			       (ask self 'MURDER (pick-random others) 
				    (pick-random weapons-i-have))
			       (delegate person-part self 'MOVE-AND-TAKE-STUFF)))))
		   #f)
	       #f)))
	((MURDER)
	 (lambda (self victim murder-weapon)
	   (ask self 'SAY (list "Heh heh heh... I spy" (ask victim 'NAME)))
	   (ask victim 'DIE)
	   (ask self 'SAY (list "Poor " (ask victim 'NAME)
				"!  Another victim of the " 
				(ask murder-weapon 'NAME)))
	   (ask self 'LOSE murder-weapon (ask self 'LOCATION))
	   (set! *has-killed-someone* true)
	   (create-thing 'bloodstain (ask self 'LOCATION) 
			 "Looks like someone died here recently....")
	   ( (crime-details 'SET)
	     (ask (ask self 'LOCATION) 'NAME)
	     (ask murder-weapon 'NAME)
	     (ask self 'NAME))
	   (for-each (lambda (suspect) (ask suspect 'SAVE-STATE)) *the-cast*)
	   (delegate person-part self 'MOVE-AND-TAKE-STUFF)
	   '*struck-again*))
	(else (get-method message person-part))))))


(define (create-killer name birthplace laziness miserly
		       murder-details characterstics) 
  (create make-killer name birthplace laziness miserly
	  murder-details characterstics))