;;------------------------------------------------------------
;; instance handler

(define (make-instance)
  (let ((handler #f))
    (lambda (message)
      (case message
	((SET-HANDLER!)
	 (lambda (handler-proc)
	   (set! handler handler-proc)))
	(else (get-method message handler))))))

;;------------------------------------------------------------
;; Root Object

(define (make-root-object self)
  (lambda (message)
    (case message
      ((TYPE)
       (lambda () '(root)))
      ((IS-A)
       (lambda (type)
	 (memq type (ask self 'TYPE))))
      (else
       (no-method)))))

;;------------------------------------------------------------
;; named-object

(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))))))

;;------------------------------------------------------------
;; thing

(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

(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))))))

;;------------------------------------------------------------
;; ask

(define (ask object message . args)
  (let ((method (get-method message object)))
    (cond ((method? method)
           (apply method args))
          (else
           (error "No method for" message 'in 
		  (safe-ask 'UNNAMED-OBJECT
			    object 'NAME))))))

;;------------------------------------------------------------
;; get-method

(define (get-method message . objects)
  (define (try objects)
    (if (null? objects)
	(no-method)
	(let ((method ((car objects) message)))
	  (if (not (eq? method (no-method)))
	      method
	      (try (cdr objects))))))
  (try objects))