;;; OBJTYPES.SCM
;;;
;;; MIT 6.001                                    Spring, 2004
;;; PROJECT 4
;;;
;;; 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:
;;  - Has a NAME that it can return
;;  - Handles an INSTALL message
;;  - Handles a DESTROY message

(define (create-named-object name)      ; symbol -> named-object
  (create-instance make-named-object name))

(define (make-named-object self name)
  (let ((root-part (make-root-object self)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'named-object root-part)))
        ((NAME) (lambda () name))
        ((INSTALL) (lambda () 'INSTALLED))
        ((DESTROY) (lambda () 'DESTROYED))
        (else (get-method message root-part))))))

(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 meant for "stand-alone" objects; rather, 
;; it is expected that other classes will inherit from the
;; container class in order to be able to contain things. 
;; For this reason, there is no create-container procedure.

(define (make-container self)
  (let ((root-part (make-root-object self))
        (things '())) ; a list of THING objects in container
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'container root-part)))
        ((THINGS) (lambda () things))
        ((HAVE-THING?)
         (lambda (thing)  ; container, thing -> boolean
           (not (null? (memq thing things)))))
        ((ADD-THING)
         (lambda (new-thing)
           (if (not (ask self 'HAVE-THING? new-thing))
               (set! things (cons new-thing things)))
           'DONE))
        ((DEL-THING)
         (lambda (thing)
           (set! things (delq thing things))
           'DONE))
        (else (get-method message root-part))))))


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

(define (create-thing name location)    ; symbol, location -> thing
  (create-instance make-thing name location))

(define (make-thing self name location)
  (let ((named-object-part (make-named-object self name)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'thing named-object-part)))
        ((INSTALL)
         (lambda ()               ; install: synchronize thing and place
           (ask named-object-part 'INSTALL)
           (ask (ask self 'LOCATION) 'ADD-THING self)))
        ((LOCATION) (lambda () location))
        ((DESTROY)
         (lambda ()             ; Destroy: remove from place
           (ask (ask self 'LOCATION) 'DEL-THING self)
           (ask named-object-part 'DESTROY)))
        ((EMIT)
         (lambda (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))))))

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

(define (create-mobile-thing name location) 
  ; symbol, location -> mobile-thing
  (create-instance make-mobile-thing name location))

(define (make-mobile-thing self name location)
  (let ((thing-part (make-thing self name location)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'mobile-thing thing-part)))
        ((LOCATION)     ; This shadows message to thing-part!
         (lambda () location))
        ((CHANGE-LOCATION)
         (lambda (new-location)
           (ask location 'DEL-THING self)
           (ask new-location 'ADD-THING self)
           (set! location new-location)))
        ((ENTER-ROOM)
         (lambda () #t))
        ((LEAVE-ROOM)
         (lambda () #t))
        ((CREATION-SITE)
         (lambda ()
           (ask thing-part 'location)))
        (else (get-method message thing-part))))))

;;--------------------
;; 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 (create-place name)     ; symbol -> place
  (create-instance make-place name))

(define (make-place self name)
  (let ((named-obj-part (make-named-object self name))
        (container-part (make-container self))
        (exits '()))    ; a list of exits
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'place named-obj-part container-part)))
        ((EXITS) (lambda () exits))
        ((EXIT-TOWARDS)
         (lambda (direction)    ; symbol -> exit
           (find-exit-in-direction exits direction)))
        ((ADD-EXIT)
         (lambda (exit)         ; exit -> symbol
           (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
         (get-method message container-part named-obj-part))))))

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

(define (create-exit from direction to)
  ; place, symbol, place -> exit
  (create-instance make-exit from direction to))

(define (make-exit self from direction to)
  (let ((named-object-part (make-named-object self direction)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'exit named-object-part)))
        ((INSTALL)
         (lambda ()
           (ask named-object-part 'INSTALL)
           (if (not (null? (ask self 'FROM)))
               (ask (ask self 'FROM) 'ADD-EXIT self))))
        ((FROM)         (lambda () from))
        ((TO)           (lambda () to))
        ((DIRECTION)    (lambda () direction))
        ((USE)
         (lambda (whom)
           (ask whom 'LEAVE-ROOM)
           (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)))
        (else (get-method message named-object-part))))))

(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 vampires, 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 (create-person name birthplace) ; symbol, place -> person
  (create-instance make-person name birthplace))

(define (make-person self name birthplace)
  (let ((mobile-thing-part (make-mobile-thing self name birthplace))
        (container-part    (make-container self))
        (health            3)
        (strength          1))
    (lambda (message)
      (case message
        ((TYPE)
         (lambda ()
           (type-extend 'person mobile-thing-part container-part)))
        ((STRENGTH) (lambda () strength))
        ((HEALTH) (lambda () health))
        ((SAY)
         (lambda (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 ()
           (ask self 'SAY '("Yaaaah! I am upset!"))
           'I-feel-better-now))
        
        ((PEOPLE-AROUND)        ; other people in room...
         (lambda ()
           (delq self (find-all (ask self 'LOCATION) 'PERSON))))
        
        ((STUFF-AROUND)         ; stuff (non people) in room...
         (lambda ()
           (let* ((in-room (ask (ask self 'LOCATION) 'THINGS))
                  (stuff (filter (lambda (x) (not (ask x 'IS-A 'PERSON))) in-room)))
             stuff)))
        
        ((PEEK-AROUND)          ; other people's stuff...
         (lambda ()
           (let ((people (ask self 'PEOPLE-AROUND)))
             (fold-right append '() (map (lambda (p) (ask p 'THINGS)) people)))))
        
        ((TAKE)
         (lambda (thing)
           (cond ((ask self 'HAVE-THING? thing)  ; already have it
                  (ask self 'SAY (list "I am already carrying"
                                       (ask thing 'NAME)))
                  #f)
                 ((or (ask thing 'IS-A 'PERSON)
                      (not (ask thing 'IS-A '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 (ask owner 'IS-A 'PERSON)
                        (ask owner 'LOSE thing self)
                        (ask thing 'CHANGE-LOCATION self))
                    thing)))))
        
        ((LOSE)
         (lambda (thing lose-to)
           (ask self 'SAY (list "I lose" (ask thing 'NAME)))
           (ask self 'HAVE-FIT)
           (ask thing 'CHANGE-LOCATION lose-to)))
        
        ((DROP)
         (lambda (thing)
           (ask self 'SAY (list "I drop" (ask thing 'NAME)
                                "at" (ask (ask self 'LOCATION) 'NAME)))
           (ask thing 'CHANGE-LOCATION (ask self 'LOCATION))))
        
        ((GO-EXIT)
         (lambda (exit)
           (ask exit 'USE self)))
        
        ((GO)
         (lambda (direction) ; symbol -> boolean
           (let ((exit (ask (ask self 'LOCATION) 'EXIT-TOWARDS direction)))
             (if (and exit (ask exit 'IS-A 'EXIT))
                 (ask self 'GO-EXIT exit)
                 (begin (ask screen 'TELL-ROOM (ask self 'LOCATION)
                             (list "No exit in" direction "direction"))
                        #F)))))
        ((SUFFER)
         (lambda (hits perp)
           (ask self 'SAY (list "Ouch!" hits "hits is more than I want!"))
           (set! health (- health hits))
           (if (<= health 0) (ask self 'DIE perp))
           health))
        
        ((DIE)          ; depends on global variable "death-exit"
         (lambda (perp)
           (for-each (lambda (item) (ask self 'LOSE item (ask self 'LOCATION)))
                     (ask self 'THINGS))
           (ask screen 'TELL-WORLD
                '("An earth-shattering, soul-piercing scream is heard..."))
           (ask self 'CREATE-BODY perp)
           (ask self 'DESTROY)))
        
        ((CREATE-BODY)
         (lambda (perp)
           (create-body (ask self 'NAME) (ask self 'LOCATION) perp)))
        
        ((ENTER-ROOM)
         (lambda ()
           (let ((others (ask self 'PEOPLE-AROUND)))
             (if (not (null? others))
                 (ask self 'SAY (cons "Hi" (names-of others)))))
           #T))
        
        (else (get-method message mobile-thing-part container-part))))))

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

(define (create-autonomous-person name birthplace activity miserly)
  (create-instance make-autonomous-person name birthplace activity miserly))

(define (make-autonomous-person self name birthplace activity miserly)
  (let ((person-part (make-person self name birthplace)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'autonomous-person person-part)))
        ((INSTALL)
         (lambda ()
           (ask person-part 'INSTALL)
           (ask clock 'ADD-CALLBACK
                (create-clock-callback 'move-and-take-stuff self 
                                       'MOVE-AND-TAKE-STUFF))))
        ((MOVE-AND-TAKE-STUFF)
         (lambda ()
           ;; 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 (perp)
           (ask clock 'REMOVE-CALLBACK self 'move-and-take-stuff)
           (ask self 'SAY '("SHREEEEK!  I, uh, suddenly feel very faint..."))
           (ask person-part 'DIE perp)))
        ((MOVE-SOMEWHERE)
         (lambda ()
           (let ((exit (random-exit (ask self 'LOCATION))))
             (if (not (null? exit)) (ask self 'GO-EXIT exit)))))
        ((TAKE-SOMETHING)
         (lambda ()
           (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))))
        (else (get-method message person-part))))))

;;--------------------
;; body
;;
;; A thing which has the potential to rise as a vampire
;;

(define (create-body name location perp)
  ; symbol, place, vampire -> body
  (create-instance make-body name location perp))

(define (make-body self name location perp)
  (let ((thing-part (make-thing self name location))
        (age 0))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'body thing-part)))
        ((INSTALL)
         (lambda ()
           (ask thing-part 'INSTALL)
           (if (ask perp 'IS-A 'VAMPIRE)
               (ask clock 'ADD-CALLBACK
                    (create-clock-callback 'age self 'WAIT)))))
        ((NAME)
         (lambda ()
           (symbol-append 'body-of- (ask thing-part 'NAME))))
        ((WAIT)
         (lambda ()
           (set! age (+ age 1))
           (if (> age 3)
               (begin
                 (ask self 'DESTROY)
                 (ask self 'EMIT (list (ask self 'NAME) "rises as a vampire!"))
                 (create-vampire name location perp)))))
        ((DESTROY)
         (lambda ()
           (ask clock 'REMOVE-CALLBACK self 'age)
           (ask thing-part 'DESTROY)))
        (else (get-method message thing-part))))))

;;--------------------
;; vampire
;;
;; An undead person that randomly attacks people.

(define (create-vampire name birthplace sire)
  ; symbol, place, vampire -> vampire
  (create-instance make-vampire name birthplace sire))

(define (make-vampire self name birthplace sire)
  (let ((person-part (make-person self name birthplace))
        (power (if sire 2 10)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'vampire person-part)))
        ((INSTALL)
         (lambda ()
           (ask person-part 'INSTALL)
           (if sire
               (ask sire 'GAIN-POWER))
           (ask clock 'ADD-CALLBACK
                (create-clock-callback 'rove-and-attack self 
                                       'ROVE-AND-ATTACK))))
        ((DIE)
         (lambda (perp)
           (ask clock 'REMOVE-CALLBACK self 'rove-and-attack)
           (ask person-part 'DIE perp)))
        ((CREATE-BODY)
         (lambda (perp)
           (ask self 'EMIT (list (ask self 'NAME) "turns to dust!"))
           'no-body-necessary))
        ((GAIN-POWER)
         (lambda ()
           (set! power (+ power 1))
           'gained-power))
        ((POWER)
         (lambda ()
           power))
        ((ROVE-AND-ATTACK)
         (lambda ()
           (if (= (random 2) 0) (ask self 'MOVE-SOMEWHERE))
           (if (< (random 3) 2) (ask self 'ATTACK-SOMEONE))
           'ok))
        ((MOVE-SOMEWHERE)
         (lambda ()
           (let ((exit (random-exit (ask self 'LOCATION))))
             (if (not (null? exit)) (ask self 'GO-EXIT exit)))))
        ((ATTACK-SOMEONE)
         (lambda ()
           (let ((others (ask self 'PEOPLE-AROUND)))
             (if (not (null? others))
                 (let ((victim (pick-random others)))
                   (ask self 'EMIT (list (ask self 'NAME) "bites"
                                         (ask victim 'NAME) "!"))
                   (ask victim 'SUFFER (random-number power) self)))
             'vampire-is-tired)))
        (else (get-method message person-part))))))

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

(define (create-avatar name birthplace)
  ; symbol, place -> avatar
  (create-instance make-avatar name birthplace))

(define (make-avatar self name birthplace)
  (let ((person-part (make-person self name birthplace)))
    (lambda (message)
      (case message
        ((TYPE) (lambda () (type-extend 'avatar person-part)))
        ((LOOK-AROUND)          ; report on world around you
         (lambda ()
           (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)
                      '("You 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 exits))
                      ;; heaven is only place with no exits
                      '("There are no exits... you are dead and gone to heaven!")))
             'OK)))
        
        ((GO)
         (lambda (direction)  ; Shadows person's GO
           (let ((success? (ask person-part 'GO direction)))
             (if success? (ask clock 'TICK))
             success?)))
        
        ((DIE)
         (lambda (perp)
           (ask self 'SAY (list "I am slain!"))
           (ask person-part 'DIE perp)))
        
        (else (get-method message person-part))))))