;;;
;;; object.ss
;;; CS150 Spring 2007
;;; Problem Set 6
;;;
;;; Simple object system with inheritance
;;;
;;; This code is loosely based on the code for MIT's 1997 Adventure Game.
;;;
;;; Version 1.0.2: Fixed problem in person 'take (delete parameters were in wrong
;;;                   order)
;;; Version 1.0.3: Revised for 2004.  Changed meaning of restlessness.
;;; Version 1.0.4: Revised for 2007.  Use make-subobject instead of explicit dispatch.
;;;

(display "Loading object.ss...")

;; All game objects inherit from this, so all game objects
;; provide the  methods object?, class, install, get-name and say.

(define make-sim-object 
  (lambda (name)
    (lambda (message)
      (if (eq? message 'object?)
	  (lambda (self) #t)
	  (if (eq? message 'class)
	      (lambda (self) 'sim-object)
	      (if (eq? message 'name)
		  (lambda (self) name)
		  (if (eq? message 'say)
		      (lambda (self list-of-stuff)
			(if (not (null? list-of-stuff))
			    (display-message list-of-stuff))
			(void))
		      (if (eq? message 'install)
			  (lambda (self . args) 'installed)
			  #f))))))))

;;;
;;; The case construct provides a convenient way of selecting
;;; the method (see the DrScheme documentation for details
;;; on case, but it is not necessary to worry about the
;;; evaluation rule for case if this example is understandable.)
;;;

(define (make-sim-object-sugared name)
  (lambda (message)
    (case message
      ((class) (lambda (self) 'sim-object))
      ((object?) (lambda (self) #t))
      ((name) (lambda (self) name))
      ((say)
        (lambda (self list-of-stuff)
          (if (not (null? list-of-stuff))
              (display-message list-of-stuff))
          (void)))
      ((install) (lambda (self . args) 'installed))
      (else #f))))

;;;
;;; get-method
;;;
;;; To get the method for a message, we just apply the object to that message.
;;;

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

;;;
;;; has-method?
;;; evaluates to #t iff the passed object has a method for handling the message
;;;

(define (has-method? object message)
  (if (get-method object message) #t #f))

;;;
;;; ask 
;;;
;;; Send a message to an object (with optional arguments)
;;;

(define (ask object message . args)
  (if (has-method? object message)
      (apply (get-method object message) object args)
      (printf "A ~a does not know how to ~a~n"
              ((get-method object 'name) object) ;; We could be in big trouble if we use ask here!
              message)))

;;;
;;; has-property?
;;;
;;; An object has-property? property if it has a method named property, and 
;;; (ask object property) evaluates to true.  We can't just evaluate
;;; (ask object property), since the method might not exist if it
;;; is not one.
;;;

(define (has-property? object property)
  (if (has-method? object property)
      (ask object property)
      #f))

;;;
;;; make-subobject
;;;
;;; make-subobject creates an object that is a subclass
;;; of the superobject, with the implementation of the
;;; overridden or extended behaviors given by the imp parameter.
;;;

(define (make-subobject super imp)
  (lambda (message)
    (if (eq? message 'super)
        (lambda (self) super)
        (let ((method (imp message)))
          (if method
              method
              (super message))))))
   
;;;
;;; Constructing Places
;;;

(define (make-place name)
  (make-subobject 
   (make-sim-object name)
   (let ((neighbor-map    '())   ; list of <direction, object> pairs
         (things          '()))  ; list of objects
     (lambda (message)
       (case message
         ((class) (lambda (self) 'place))
         ((is-place?) (lambda (self) #t))
         ((reset) (lambda (self)
                    (set! neighbor-map '())
                    (set! things '())))
         ((things) (lambda (self) things))
         ((neighbors)
          (lambda (self) (map cdr neighbor-map)))
         ((exits)
          (lambda (self) (map car neighbor-map)))
         ((neighbor-towards)
          (lambda (self direction)
            (let ((what (assq direction neighbor-map)))
              (if what
                  (cdr what)
                  #f))))
         ((add-neighbor)
          (lambda (self direction new-neighbor)
            (if (ask self 'neighbor-towards direction)
                (ask self 'say
                     (list name "already has a neighbor to the "
                           direction))
                (begin
                  (set! neighbor-map
                        (cons (cons direction new-neighbor)
                              neighbor-map))
                  #t))))
         ((have-thing?)
          (lambda (self thing) (memq thing things)))
         
         ;; Following two methods should never be called by the player.
         ;; they are system-internal methods. See change-location instead.
         
         ((_add-thing!)
          (lambda (self new-thing)
            (if (not (ask self 'have-thing? new-thing))
                (set! things (cons new-thing things)))
            #t))
         ((_del-thing!)
          (lambda (self thing)
            (cond ((not (ask self 'have-thing? thing))
                   (ask self 'say
                        (list (ask thing 'name) " is no longer at " name)))
                  (else (set! things (delete things thing)) ;; delete defined in listprocs.ss
                        #t))))
         (else #f))))))
  
;;; Physical objects have a location as well as a name

(define no-place (make-place 'not-yet-installed))

(define (make-physical-object name)
  (make-subobject
   (make-sim-object name)
   (let ((location no-place)) ; location set when we install
     (lambda (message) ; Normal actions
       (case message
         ((class) (lambda (self) 'physical-object))
         ((physical-object?) (lambda (self) #t))
         ((location) (lambda (self) location))
         ((_set-location!) ;;; should not be called directly
          (lambda (self where) 
            (set! location where)))
         ((install)
          (lambda (self where) 
            (ask self 'say (list "Installing " (ask self 'name) " at " (ask where 'name)))
            (ask self '_set-location! where)
            (if (has-property? where 'is-place?)
                (ask where '_add-thing! self)
                (ask self 'say
                     (list (ask my-place 'name)
                           "is not a location")))))
         (else #f))))))

;;; Mobile objects have a location that can change

(define (make-mobile-object name)
  (make-subobject
   (make-physical-object name)
   (lambda (message)
     (case message
       ((class) (lambda (self) 'mobile-object))
       ((mobile-object?) (lambda (self) #t))
       ((change-location)
        (lambda (self new-place)
          (ask (ask self 'location) '_del-thing! self)
          (ask new-place '_add-thing! self)
          (ask self '_set-location! new-place)))
       (else #f)))))

;;;
;;; Constructing things 
;;;

(define (make-thing name)
  (make-subobject
   (make-mobile-object name)
   (let ((owner 'nobody))
     (lambda (message)
       (case message
         ((class) (lambda (self) 'thing))
         ((thing?) (lambda (self) #t))
         ((owner) (lambda (self) owner))
         ((owned?) (lambda (self) (not (eq? owner 'nobody))))
         ;; The set-owner! method should never be called by the user (it is
         ;; a system-internal method). Doing so may cause two owners to
         ;; think they both own the THING.
         ;; See TAKE and LOSE instead.
         ((set-owner!)
          (lambda (self new-owner)
            (set! owner new-owner)
            'owner-set))
         (else #f))))))

(define (ownable? object)
  (has-property? object 'thing?))

;;; Clock routines

(define (make-world-clock)
  (make-subobject
   (make-sim-object 'world-clock)
   (let ((global-time 0)
         (clock-list null))
     (lambda (message)
       (case message
         ((class) (lambda (self) 'world-clock))
         ((add)
          (lambda (self object)
            (set! clock-list (cons object clock-list))
            'added))
         ((remove)
          (lambda (self object)
            (delete clock-list object)
            'removed))
         ((time-of-day) (lambda (self) global-time))
         ((tick) 
          (lambda (self)
            (set! global-time (+ global-time 1))
            (printf "[Clock] Tick ~a~n" global-time)
            (for-each (lambda (thing) 
                        (ask thing 'clock-tick))
                      clock-list)
            (newline)
            'tick-tock))
         ((run-clock)
          (lambda (self n)
            (n-times (lambda () (ask self 'tick)) n)))
         (else #f))))))
  
;;; Does not put spaces between messages
(define (display-message list-of-stuff)
  (for-each (lambda (s) (display s))
            list-of-stuff)
  (newline)
  (void))

(define (random-neighbor place)
  (pick-random (ask place 'neighbors)))

(define (pick-random lst)
  (if (null? lst)
      (error "No elements")
      (get-nth lst (+ 1 (random (length lst))))))

(define (find-all place predicate)
  (filter (lambda (thing) (has-property? thing predicate))
          (ask place 'things)))

(define (other-people-at-place person place)
  (filter (lambda (x) 
            ;; Note that we can't use eq? to compare the objects,
            ;; since person might be the super-object.
	    (not (eq? (ask x 'name) (ask person 'name))))
	  (find-all place 'person?)))

;;;
;;; People
;;;

(define (make-person name)
  (make-subobject
   (make-mobile-object name) ;; A person is a kind of mobile object
   (let ((possessions '())  ;;; What the person is carrying (a list of Objects that are things
         (restlessness 0.0))  ;;; How likely the person is to move randomly
     (lambda (message)
       (case message
         ((class) (lambda (self) 'person))
         ((person?) (lambda (self) #t))
         ((get-possessions) (lambda (self) possessions))
         ((display-possessions)
          (lambda (self)
            (let ((my-stuff (ask self 'get-possessions)))
              (ask self 'say
                   (cons "I have"
                         (if (null? my-stuff)
                             '("nothing")
                             (map (lambda (p) (ask p 'name))
                                  my-stuff))))
              my-stuff)))
         ((say)
          (lambda (self list-of-stuff)
            (display-message
             (append (list "At " (ask (ask self 'location) 'name)
                           ": "  name " says -- ")
                     (if (null? list-of-stuff)
                         '("Oh, nevermind.")
                         list-of-stuff)))
            'said))
         ((have-fit)
          (lambda (self)
            (ask self 'say '("Yaaaah! I am upset!"))
            'I-feel-better-now))
         ((look)
          (lambda (self)
            (let ((other-things
                   ;;; Don't see yourself, so delete it from the things
                   (map
                    (lambda (sym) (string-append (symbol->string sym) " "))
                    (filter
                     (lambda (name) (not (eq? name (ask self 'name))))
                     (map (lambda (thing) (ask thing 'name))
                          (ask (ask self 'location) 'things))))))
              (ask self 'say (cons "I see " (if (null? other-things)
                                                '("nothing")
                                                other-things)))
              (ask self 'say (cons "I can go " 
                                   (map
                                    (lambda (dir)
                                      (string-append (symbol->string dir) " "))
                                    (ask (ask self 'location) 'exits))))
              other-things))) ;;; Evaluate to the list of things
         ((take)
          (lambda (self thing)
            (cond ((member? thing possessions)
                   (ask self 'say
                        (list "I already have " (ask thing 'name)))
                   #f)
                  ((and (member? thing  (ask (ask self 'location) 'things))
                        (ownable? thing))
                   (if (ask thing 'owned?)
                       (let ((owner (ask thing 'owner)))
                         (ask owner 'lose thing)
			 'unowned))
                   (ask thing 'set-owner! self)
                   (set! possessions (cons thing possessions))
                   (ask self 'say
                        (list "I take " (ask thing 'name)))
                   #t)
                  (else
                   (display-message
                    (list "You cannot take " (ask thing 'name)))
                   #f))))
         ((lose)
          (lambda (self thing)
            (if (eq? self (ask thing 'owner))
                (begin
                  (set! possessions (delete possessions thing))
                  (ask thing 'set-owner! 'nobody)
                  (ask self 'say (list "I lose" (ask thing 'name)))
		  (ask self 'have-fit))
                #t)
            (begin
              (display-message (list name " does not own "
                                     (ask thing 'name)))
              #f)))         
         ((is-dressed?) 
          (lambda (self) 
            ;;; Normal people are always dressed (when in public places).
            #t))       
         ((make-restless)
          (lambda (self value)
            (set! restlessness value)))
         ((clock-tick)
          (lambda (self)
            (if (< (/ (random 100000) 100000) restlessness)
                (ask self 'act-randomly)
                #f)))
         ((act-randomly)
          (lambda (self)
            (let ((new-place (random-neighbor (ask self 'location))))
              (if new-place
                  (ask self 'move-to new-place)
                  #f)))) ; No place to go
         ((move-to)
          (lambda (self new-place)
            (let ((old-place (ask self 'location))
                  (my-stuff (ask self 'get-possessions)))
              (define (greet-people person people)
                (if (not (null? people))
                    (ask person 'say
                         (cons "Hi "
                               (map (lambda (p) (string-append (symbol->string (ask p 'name)) " "))
                                    people)))
                    'sure-is-lonely-in-here))
              (cond 
                ((has-property? new-place 'is-place?)
                 (display-message
                  (list name " moves from " (ask old-place 'name)
                        " to " (ask new-place 'name)))
                 (ask self 'change-location new-place)
                 (for-each
                  (lambda (p) (ask p 'change-location new-place))
                  my-stuff)
                 (greet-people self
                               (other-people-at-place self new-place))
                 #t)
                (else
                 (display-message (list name " can't move to "
                                        (ask new-place 'name))))))))
         ((go)
          (lambda (self direction)
            (let ((old-place (ask self 'location)))
              (let ((new-place (ask old-place 'neighbor-towards direction)))
                (if new-place
                    (ask self 'move-to new-place)
                    (begin
                      (display-message
                       (list "You cannot go " direction
                             " from " (ask old-place 'name)))
                      #f))))))
         (else #f))))))
  
(define (make-lecturer name)
  (make-subobject
   (make-sim-object name)
   (lambda (message)
     (if (eq? message 'lecture)
         (lambda (self stuff)
           (ask self 'say stuff)
           (ask self 'say (list "you should be taking notes")))
         #f))))

(printf "Done loading objects.scm.~n")