;; ADV.SCM
;; This file contains the definitions for the objects in the adventure
;; game and some utility procedures.

(define-class (basic-object)
  (instance-vars (properties (make-table)))
  (method (put type num)
    (insert! type num properties))
  (default-method 
    (lookup message properties)))

(define-class (place name)
  (parent (basic-object))
  (instance-vars
   (directions-and-neighbors '())
   (things '())
   (people '())
   (entry-procs '())
   (exit-procs '()))
  (method (may-enter? per) #t)
  (method (place?) #t)
  (method (type) 'place)
  (method (neighbors) (map cdr directions-and-neighbors))
  (method (exits) (map car directions-and-neighbors))
  (method (look-in direction)
    (let ((pair (assoc direction directions-and-neighbors)))
      (if (not pair)
	  '()                     ;; nothing in that direction
	  (cdr pair))))           ;; return the place object
  (method (appear new-thing)
    (if (memq new-thing things)
	(error "Thing already in this place" (list name new-thing)))
    (set! things (cons new-thing things))
    'appeared)
  (method (enter new-person)
    (if (memq new-person people)
	(error "Person already in this place" (list name new-person)))
    (begin (map (lambda (old-one) (ask old-one 'notice new-person)) people)
    (set! people (cons new-person people))
    (for-each (lambda (proc) (proc)) entry-procs)
    'appeared))
  (method (gone thing)
    (if (not (memq thing things))
	(error "Disappearing thing not here" (list name thing)))
    (set! things (delete thing things)) 
    'disappeared)
  (method (exit person)
    (for-each (lambda (proc) (proc)) exit-procs)
    (if (not (memq person people))
	(error "Disappearing person not here" (list name person)))
    (set! people (delete person people)) 
    'disappeared)

  (method (new-neighbor direction neighbor)
    (if (assoc direction directions-and-neighbors)
	(error "Direction already assigned a neighbor" (list name direction)))
    (set! directions-and-neighbors
	  (cons (cons direction neighbor) directions-and-neighbors))
    'connected)

  (method (add-entry-procedure proc)
    (set! entry-procs (cons proc entry-procs)))
  (method (add-exit-procedure proc)
    (set! exit-procs (cons proc exit-procs)))
  (method (remove-entry-procedure proc)
    (set! entry-procs (delete proc entry-procs)))
  (method (remove-exit-procedure proc)
    (set! exit-procs (delete proc exit-procs)))
  (method (clear-all-procs)
    (set! exit-procs '())
    (set! entry-procs '())
    'cleared) )

(define-class (locked-place name)
  (parent (place name))
  (instance-vars (locker #f))
  (method (unlock) (set! locker #t))
  (method (lock) (set! locker #f))
  (method (may-enter? per) locker))

(define-class (restaurant name food-type cost)
  (parent (place name))
  (method (menu) (list (ask food-type 'name) cost))
  (method (sell custom item)
	  (if (and (eq? (ask food-type 'name) item)
		   (ask custom 'pay-money cost))
	      (let ((x (instantiate food-type)))
		(ask self 'appear x)
		x)
	      #f)))

(define-class (person name place)
  (parent (basic-object))
  (instance-vars
   (possessions '())
   (saying ""))
  (initialize
   (ask place 'enter self)
   (ask self 'put 'strength 100)
   (ask self 'put 'money 100))
  (method (type) 'person)
  (method (person?) #t)
  (method (look-around)
    (map (lambda (obj) (ask obj 'name))
	 (filter (lambda (thing) (not (eq? thing self)))
		 (append (ask place 'things) (ask place 'people)))))
  (method (get-money n)
	  (ask self 'put 'money (+ n (ask self 'money)))
	  'ok)
  (method (pay-money n)
	  (let ((k (ask self 'money)))
	    (if (< k n)
		#f
		(begin (ask self 'put 'money (- k n))
		       #t))))
  (method (take-all)
	  (let ((a (ask (ask self 'place) 'things)))
	    (let ((all (map (lambda (thing)
			      (if (eq? 'no-one (ask thing 'possessor))
				  thing
				  #f))
			    a)))
	      (map (lambda (one) (ask self 'take one)) (remove #f all)))))
  (method (buy item)
	  (let ((x  (ask place 'sell self item)))
	    (if x
		(ask self 'take x)
		#f)))
  (method (take thing)
    (cond ((not (ask thing 'thing?)) (error "Not a thing" thing))
	  ((not (memq thing (ask place 'things)))
	   (error "Thing taken not at this place"
		  (list (ask place 'name) thing)))
	  ((memq thing possessions) (error "You already have it!"))
	  (else
	   (announce-take name thing)
	   (set! possessions (cons thing possessions))
	       
	   ;; If somebody already has this object...
	   (for-each
	    (lambda (pers)
	      (if (and (not (eq? pers self)) ; ignore myself
		       (memq thing (ask pers 'possessions)))
		  (begin
		   (ask pers 'lose thing)
		   (have-fit pers))))
	    (ask place 'people))
	       
	   (ask thing 'change-possessor self)
	   'taken)))
  (method (eat)
    (let ((foods (filter (lambda (one)
			   (ask one 'edible?))
			 (ask self 'possessions))))
      (map (lambda (one)
	     (let ((cal (ask one 'calories)))
	       (ask self 'put 'strength (+ (ask self 'strength) cal))
	       (ask self 'lose one)
	       (ask place 'gone one)))
	   foods)))
  
  (method (lose thing)
    (set! possessions (delete thing possessions))
    (ask thing 'change-possessor 'no-one)
    'lost)
  (method (talk) (print saying))
  (method (set-talk string) (set! saying string))
  (method (exits) (ask place 'exits))
  (method (notice person) (ask self 'talk))
  (method (go direction)
    (let ((new-place (ask place 'look-in direction)))
      (cond ((null? new-place)
	     (error "Can't go" direction))
	    ((not (ask new-place 'may-enter? self))
	     (display (ask new-place 'name))
	     (display " locked")
	     (newline))
	    (else
	     (ask place 'exit self)
	     (announce-move name place new-place)
	     (for-each
	      (lambda (p)
		(ask place 'gone p)
		(ask new-place 'appear p))
	      possessions)
	     (set! place new-place)
	     (ask new-place 'enter self))))) )

;(define thing
;  (let ()
;    (lambda (class-message)
;      (cond
;       ((eq? class-message 'instantiate)
;	(lambda (name)
;	  (let ((self '()) (possessor 'no-one))
;	    (define (dispatch message)
;	      (cond
;	       ((eq? message 'initialize)
;		(lambda (value-for-self)
;		  (set! self value-for-self)))
;	       ((eq? message 'send-usual-to-parent)
;		(error "Can't use USUAL without a parent." 'thing))
;	       ((eq? message 'name) (lambda () name))
;	       ((eq? message 'possessor) (lambda () possessor))
;	       ((eq? message 'type) (lambda () 'thing))
;	       ((eq? message 'change-possessor)
;		(lambda (new-possessor)
;		  (set! possessor new-possessor)))
;	       (else (no-method 'thing))))
;	    dispatch)))
;       (else (error "Bad message to class" class-message))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;define things
;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class (thing name)
  (parent (basic-object))
  (instance-vars (possessor 'no-one))
  (method (name) name)
  (method (thing?) #t)
  (method (possessor) possessor)
  (method (type) 'thing)
  (method (change-possessor new-possessor)
	  (set! possessor new-possessor)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define class food
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-class (food name cal)
  (parent (thing name))
  (method (edible?) #t)
  (method (calories) cal))

(define-class (bagel)
  (parent (food 'bagel 10))
  (class-vars (name 'bagel)))

(define-class (coffee)
  (parent (food 'coffee 3))
  (class-vars (name 'coffee)))

(define-class (big-mac)
  (parent (food 'big-mac 20))
  (class-vars (name 'big-mac)))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Implementation of thieves for part two
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (edible? thing)
  (ask thing 'edible?))

(define-class (thief name initial-place)
  (parent (person name initial-place))
  (instance-vars
   (behavior 'steal))
  (method (type) 'thief)

  (method (notice person)
    (if (eq? behavior 'run)
	(ask self 'go (pick-random (ask (usual 'place) 'exits)))
	(let ((food-things
	       (filter (lambda (thing)
			 (and (edible? thing)
			      (not (eq? (ask thing 'possessor) self))))
		       (ask (usual 'place) 'things))))
	  (if (not (null? food-things))
	      (begin
	       (ask self 'take (car food-things))
	       (set! behavior 'run)
	       (ask self 'notice person)) )))) )

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility procedures
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; this next procedure is useful for moving around

(define (move-loop who)
  (newline)
  (print (ask who 'exits))
  (display "?  > ")
  (let ((dir (read)))
    (if (equal? dir 'stop)
	(newline)
	(begin (ask who 'go dir)
	       (move-loop who)))))


;; One-way paths connect individual places.

(define (can-go from direction to)
  (ask from 'new-neighbor direction to))


(define (announce-take name thing)
  (newline)
  (display name)
  (display " took ")
  (display (ask thing 'name))
  (newline))

(define (announce-move name old-place new-place)
  (newline)
  (newline)
  (display name)
  (display " moved from ")
  (display (ask old-place 'name))
  (display " to ")
  (display (ask new-place 'name))
  (newline))

(define (have-fit p)
  (newline)
  (display "Yaaah! ")
  (display (ask p 'name))
  (display " is upset!")
  (newline))


(define (pick-random set)
  (nth (random (length set)) set))

(define (delete thing stuff)
  (cond ((null? stuff) '())
	((eq? thing (car stuff)) (cdr stuff))
	(else (cons (car stuff) (delete thing (cdr stuff)))) ))

;(define (person? obj)
;  (and (procedure? obj)
;       (member? (ask obj 'type) '(person police thief))))
;
;(define (thing? obj)
;  (and (procedure? obj)
;       (eq? (ask obj 'type) 'thing)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;some user-defined utility
;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (show-people aplace)
  (map (lambda (x)
	 (ask x 'name))
       (ask aplace 'people)))

(define (show-things people)
  (map (lambda (x)
	 (ask x 'name))
       (ask people 'possessions)))

(define (whereis people)
  (ask (ask people 'place) 'name))

(define (owner thing)
  (let ((f (ask thing 'possessor)))
    (if (word? f)
	f
	(ask f 'name))))

(define (find-neighbor aplace)
  (let ((alist (ask aplace 'directions-and-neighbors)))
    (define (find-one arg)
      (list (car arg)
	    (ask (cdr arg) 'name)))
    (map find-one alist)))