;;;
;;; CS 200
;;; Problem Set 6
;;;
;;; object.ss
;;;
;;; 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)
;;;

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

(define no-method #f)

;; All objects inherit from this, so we are guaranteed that any
;; object can respond to the messages object?, class, install,
;; name and say.

(define make-object 
  (lambda (name)
    (lambda (message)
      (if (eq? message 'object?)
	  (lambda (self) #t)
	  (if (eq? message 'class)
	      (lambda (self) '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))
			'nuf-said)
		      (if (eq? message 'install)
			  (lambda (self . args) 'installed)
			  #f))))))))

(define (make-object-sugared name)
  (lambda (message)
    (case message
      ((class) (lambda (self) '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))
          'nuf-said))
      ((install) (lambda (self . args) 'installed))
      (else no-method))))

;;;
;;; 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)
  (not (eq? no-method (get-method object message))))

(define (method? x)
  (cond ((procedure? x) #T)
        ((eq? x (no-method)) #F)
        (else (error "Object returned this non-message:" x))))

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

(define (ask object message . args)
  (let ((method (get-method object message)))
    (if method
	(apply method object args)
	(begin
	  (printf "A ~a does not know how to ~a~n"
		  ;; We're in big trouble if something doesn't have name, if we use ask here!
		  ((get-method object 'name) object) message)
	  #f))))

;;;
;;; is-a
;;;
;;; An object is-a 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 (is-a object property)
  (if (has-method? object property)
      (ask object property)
      #f))

;;;
;;; Constructing Places
;;;

(define (make-place name)
  (let ((neighbor-map    '())           ; Alist, direction -> object
        (things          '())
        (super           (make-object name)))
    (lambda (message)
      (case message
	((class) (lambda (self) 'place))
	((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)))) 
	
	;;; Inherit all methods of object
	(else (get-method super message))))))

;;; Physical objects have a location as well as a name

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

(define (make-physical-object name)
  (let ((super (make-object name))
	;; instance variable
	(location null-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 (is-a where 'place?)
	       (ask where '_add-thing! self)
	       (ask self 'say
		    (list (ask my-place 'name)
			  "is not a location")))))
	(else (get-method super message))))))

;;; Mobile objects have a location that can change

(define (make-mobile-object name)
  (let ((super (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 (get-method super message))))))

;;;
;;; Constructing things 
;;;

(define (make-thing name)
  (let ((super (make-mobile-object name))
        (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 (get-method super message))))))

(define (ownable? object)
  (is-a object 'thing?))

;;; Clock routines

(define (make-world-clock)
  (let ((super (make-object 'world-clock))
	(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 (get-method super message))))))

;;; Does not put spaces between messages
(define (display-message list-of-stuff)
  (for-each (lambda (s) (display s))
            list-of-stuff)
  (newline)
  'MESSAGE-DISPLAYED)

(define (random-number n)
  ;; Generate a random number between 1 and n
  (+ 1 (random n)))

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

(define (pick-random lst)
  (if (null? lst)
      #f
      (list-ref lst (random (length lst)))))  ;; (list-ref lst k) evaluates to the kth element of the list lst

;;;
;;; filter is defined in listprocs.ss
;;;

(define (find-all place predicate)
  (filter (lambda (thing) (is-a thing predicate))
          (ask place 'things)))

(define (find-all-other place predicate what)
  ;; Find all things at PLACE that satisfy PREDICATE but aren't WHAT
  (filter (lambda (x) 
	    (not (eq? x what))) 
	  (find-all place predicate)))

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

;;;
;;; People
;;;

(define (make-person name)
  (let (;; A person is a kind of mobile object
	(super (make-mobile-object name))
	
	;; Instance variables
        (possessions '())  ;;; What the person is carrying (a list of Objects that are things
	(restlessness #f)  ;;; 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)))
	;;; Normal people are always dressed.
	((is-dressed?) (lambda (self) #t))
	
	((make-restless)
	 (lambda (self value)
	   (set! restlessness value)))
	((clock-tick)
	 (lambda (self)
	   (if restlessness
	       (if (= (random restlessness) 0)
		   (ask self 'act-randomly)
		   #f)
	       #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 
	      ((is-a new-place '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 (get-method super message))))))

(display "done.")
(newline)