;;;                  MASSACHVSETTS INSTITVTE OF TECHNOLOGY
;;;        Department of Electrical Engineering and Computer Science
;;;        6.001---Structure and Interpretation of Computer Programs
;;;                           Spring Semester, 1997
;;;                              Problem Set 6
;;;
;;;                         Code file OBJECTS.SCM


;;; ----------------------------------------------------------------------------
;;; Simple object system with inheritance

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

(define no-method
  (let ((tag (list 'NO-METHOD)))
    (lambda () tag)))

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

(define (delegate to from message . args)
  ;; See your Scheme manual to explain `.'
  ;; FROM wants TO to handle a message on its behalf
  ;; This assumes that *all* objects inherit from NAMED-OBJECT
  (let ((method (get-method message to)))
    (cond ((method? method)
           (apply method from args))
          ((eq? to from)
           (error "No method for" message "in" (ask from 'NAME)))
          (else (error "Can't delegate" message
                       "from" (ask from 'NAME)
                       "to" (ask to 'NAME))))))

(define (ask object message . args)
  ;; See your Scheme manual to explain `.'
  ;; Just delegate from the OBJECT to itself!
  (apply delegate object object message args))

(define (delegate-to-all to-list from message . args)
  ;; FROM wants all the objects in TO-LIST to handle a message
  (for-each
   (lambda (to-whom)
     (apply delegate to-whom from message args))
   to-list))

(define (get-method message preferred . others)
  ;; Get the "best" method, assuming objects are ordered from best to
  ;; worst.
  (define (loop objs)
    (let ((method (get-method-from-object message (car objs)))
          (rest (cdr objs)))
      (if (or (method? method) (null? rest))
          method
          (loop rest))))
  (loop (cons preferred others)))

;;                               - OBJECTS - 1 -
(define (installer type-maker)
  ;; Returns a procedure that makes an object of a given type, then
  ;; installs and returns it.
  (lambda args
    (let ((object (apply type-maker args)))
      (ask object 'INSTALL)
      object)))

(define *Debugging-Installation?* #F)

(define (install-shield me)
  ;; The input, ME, is the core of an object (i.e. a procedure that
  ;; accepts a message telling it what to do and returning a method
  ;; for doing it).  INSTALL-SHIELD returns the actual object that
  ;; will do the work.  It just tests to see if the message is INSTALL
  ;; or not, and makes sure that the installation happens once and
  ;; only once.
  (if *Debugging-Installation?*
      (let ((installed? #F))
        (lambda (message)
          (if (eq? message 'INSTALL)
              (if installed?
                  (lambda (self)
                    (error "Already installed" me))
                  (set! installed? #T))
              (if (not installed?)
                  (lambda (self . args)
                    (error "Not installed yet" me))
                  'OK))
          (me message)))
      me))

;;; Persons, places, and things will all be kinds of named objects

(define (make-named-object name)
  ;; All objects inherit from this, so we are guaranteed that any
  ;; object can respond to the messages NAME, INSTALL, and SAY.
  (install-shield
   (lambda (message)
     (case message
       ((NAMED-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) 'INSTALLED))
       (else (no-method))))))

(define make&install-named-object (installer make-named-object))


;;                               - OBJECTS - 2 -
;;; Implementation of places

(define (make-place name)
  (let ((neighbor-map    '())           ; Alist, direction -> object
        (things       '())
        (named-obj (make-named-object name)))
    (install-shield
     (lambda (message)
       (case message
         ((PLACE?) (lambda (self) #T))
         ((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))
                  true))))
         ((HAVE-THING?)
          (lambda (self thing) (memq thing things)))
         ;; Following two methods should never be called by the user...
         ;;  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)))
            true))
         ((DEL-THING)
          (lambda (self thing)
            (cond ((not (ask self 'HAVE-THING? thing))
                   (ask self 'SAY
                        (list (ask thing 'NAME) "is not at" name)))
                  (else (set! things (delq thing things)) ;; DELQ defined
                        true)))) ;; below
         (else (get-method message named-obj)))))))

(define make&install-place (installer make-place))

;;                               - OBJECTS - 3 -
;;; Physical objects have a location as well as a name

(define (make-physical-object name location)
  (let ((named-object (make-named-object name)))
    (install-shield
      (lambda (message) ; Normal actions
        (case message
          ((PHYSICAL-OBJECT?) (lambda (self) #T))
          ((LOCATION) (lambda (self) location))
          ((INSTALL)
           (lambda (self) ; Install: synchronize thing and place
             (let ((my-place (ask self 'LOCATION)))
               (if (is-a my-place 'PLACE?)
                   (begin
                     (ask my-place 'ADD-THING self)
                     (delegate named-object self 'INSTALL))
                   (ask self 'SAY
                        (list (ask my-place 'NAME)
                              "is not a LOCATION"))))))
          (else (get-method message named-object)))))))

(define make&install-physical-object
  (installer make-physical-object))

;;; Mobile objects have a location that can change

(define (make-mobile-object name location)
  (let ((physical-obj (make-physical-object name location)))
    (install-shield
     (lambda (message)
       (case message
         ((MOBILE-OBJECT?) (lambda (self) #T))
         ((LOCATION) ;; This shadows message to physical object
          (lambda (self) location))
         ((CHANGE-LOCATION)
          (lambda (self new-place)
            (ask location 'DEL-THING self)
            (ask new-place 'ADD-THING self)
            (set! location new-place)))
         (else (get-method message physical-obj)))))))

(define make&install-mobile-object
  (installer make-mobile-object))


;;                               - OBJECTS - 4 -
;;; Things are owned

(define (make-thing name place)
  (let ((mobile-obj (make-mobile-object name place))
        (owner 'NOBODY)
        (installed? #F))
    (install-shield
      (lambda (message)
        (case message
          ((THING?) (lambda (self) #t))
          ((OWNER) (lambda (self) owner))
          ((OWNED?) (lambda (self) (not (eq? owner 'NOBODY))))
          ;; Following 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 message mobile-obj)))))))

(define make&install-thing (installer make-thing))

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

;;; Clock routines

(define *clock-list* '())
(define *the-time* 0)

(define (initialize-clock-list)
  (set! *clock-list* '())
  (set! *the-time* 0)
  'INITIALIZED)

(define (add-to-clock-list thing)
  (set! *clock-list* (cons thing *clock-list*))
  'ADDED)

(define (remove-from-clock-list thing)
  (set! *clock-list* (delq thing *clock-list*))  ;; DELQ defined below
  'REMOVED)

(define (clock)
  (newline)
  (display "---Tick ") (display *the-time*) (display "---")
  (newline)
  (set! *the-time* (+ *the-time* 1))
  (for-each (lambda (thing) (ask thing 'CLOCK-TICK))
            *clock-list*)
  (newline)
  'TICK-TOCK)

(define (current-time)
  *the-time*)


;;                               - OBJECTS - 5 -
(define (run-clock n)
  (cond ((zero? n) 'DONE)
        (else (clock)
              (run-clock (-1+ n)))))

;;; Miscellaneous procedures

(define (is-a object property)
  (let ((method (get-method property object)))
    (if (method? method)
        (ask object property)
        false)))

(define (display-message list-of-stuff)
  (newline)
  (for-each (lambda (s) (display s) (display " "))
            list-of-stuff)
  '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 (filter predicate lst)
  (cond ((null? lst) '())
        ((predicate (car lst))
         (cons (car lst) (filter predicate (cdr lst))))
        (else (filter predicate (cdr lst)))))

(define (pick-random lst)
  (if (null? lst)
      false
      (list-ref lst (random (length lst)))))  ;; See manual for LIST-REF

(define (delq item lst)
  (cond ((null? lst) '())
        ((eq? item (car lst)) (delq item (cdr lst)))
        (else (cons (car lst) (delq item (cdr lst))))))

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

;;; A gift from the (Scheme) Gods


;;                               - OBJECTS - 6 -
(define (show thing)
  (define (global-environment? frame)
    (environment->package frame))
  (define (pp-binding name value width)
    (let ((value* (with-string-output-port
                   (lambda (port)
                     (if (pair? value)
                         (pretty-print value port #F (+ width 2))
                         (display value port))))))
      (newline)
      (display name)
      (display ": ")
      (display (make-string (- width (string-length name)) #\Space))
      (if (pair? value)
          (display (substring value* (+ width 2) (string-length value*)))
          (display value*))))
  (define (show-frame frame)
    (if (global-environment? frame)
        (display "\nGlobal Environment")
        (let* ((bindings (environment-bindings frame))
               (parent   (environment-parent frame))
               (names    (cons "Parent frame"
                               (map symbol->string (map car bindings))))
               (values   (cons (if (global-environment? parent)
                                   'GLOBAL-ENVIRONMENT
                                   parent)
                               (map cadr bindings)))
               (width    (reduce max 0 (map string-length names))))
          (for-each (lambda (n v) (pp-binding n v width))
            names values))))
  (define (show-procedure proc)
    (fluid-let ((*unparser-list-depth-limit* 4)
                (*unparser-list-breadth-limit* 4))
      (newline)
      (display "Frame:")
      (newline)
      (display "  ")
      (if (global-environment? (procedure-environment proc))
          (display "Global Environment")
          (display (procedure-environment proc)))
      (newline)
      (display "Body:")
      (newline)
      (pretty-print (procedure-lambda proc) (current-output-port) #T 2)))

  (define (print-nicely thing)
    (newline)
    (display thing)
    (cond ((false? thing)
           'UNINTERESTING)
          ((environment? thing)
           (show-frame thing))
          ((compound-procedure? thing)
           (show-procedure thing))
          (else 'UNINTERESTING)))
  (print-nicely
   (or (if (exact-integer? thing)
           (object-unhash thing)
           thing)
       thing)))
;;                               - OBJECTS - 7 -