;;;                  MASSACHVSETTS INSTITVTE OF TECHNOLOGY
;;;        Department of Electrical Engineering and Computer Science
;;;        6.001---Structure and Interpretation of Computer Programs
;;;                           Fall Semester, 1996
;;;                              Problem Set 7
;;;
;;;                         Code file GAME.SCM


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

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

(define (no-method) '(NO-METHOD))

(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)))
    (if (method? method)
        (apply method from args)
        (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)))            

;;; 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.
  (lambda (message) 
    (case message
      ((NAME) (lambda (self) name))
      ((INSTALL) (lambda (self) 'OK))
      ((SAY)
       (lambda (self list-of-stuff)
         (if (not (null? list-of-stuff))
             (display-message list-of-stuff))
         'NUF-SAID))
      (else (no-method)))))

;;; Persons and things are mobile since their places can change

(define (make-physical-object name location)
  (let ((named-object (make-named-object name)))
    (lambda (message)
      (case message
        ((LOCATION) (lambda (self) location))
        ((INSTALL)
         (lambda (self)         ; Synchronize thing and place
           (ask (ask self 'LOCATION) 'ADD-THING self)
           (delegate named-object self 'INSTALL)))
        (else (get-method message named-object))))))

(define (make-mobile-object name location)
  (let ((physical-obj (make-physical-object name location)))
    (lambda (message)
      (case message
        ((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))))))

;;; Implementation of places

(define (make-place name)
  (let ((neighbors    '())
        (neighbor-names '())
        (things       '())
        (named-obj (make-named-object name)))
    (lambda (message)
      (case message
        ((THINGS) (lambda (self) things))
        ((NEIGHBORS)
         (lambda (self) neighbors))
        ((ADD-NEIGHBOR)
         (lambda (self new-neighbor)
           (if (memq new-neighbor neighbors)
               (ask self 'SAY
                    (list name "already has a neighbor of"
                          (ask new-neighbor 'NAME)))
               (let ((new-name (ask new-neighbor 'NAME)))
                 (if (memq new-name neighbor-names)
                     (ask self 'SAY
                          (list name
                                "is getting an additional neighbor named"
                                new-name)))
                 (set! neighbors (cons new-neighbor neighbors))
                 (set! neighbor-names (cons new-name neighbor-names))
                 true))))
 
      ;; 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 (memq new-thing things))
             (set! things (cons new-thing things)))
         true))
      ((DEL-THING)
       (lambda (self thing)
         (cond ((not (memq thing things))
                (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))))))

;;; Cities are special kinds of places: debates happen there,
;;; and there are voters!

(define (make-city name)
  (let ((place (make-place name)))
    (lambda (message)
      (case message
        ((CLOCK-TICK)
         (lambda (self) (ask self 'SPONSOR-DEBATE)))
        ((INSTALL)
         (lambda (self)
           (add-to-clock-list self)
           (delegate place self 'INSTALL)))
        ((SPONSOR-DEBATE)
         (lambda (self)
           (let* ((candidates (find-all self 'POLITICIAN?))
                  (ncandidates (length candidates)))
             (if (> ncandidates 1)
                 ;; More than one politician?  Could be time for a
                 ;; debate...
                 (let* ((debaters
                         (filter (lambda (pol) (ask pol 'DEBATE?))
                                 candidates))
                        (ndebaters (length debaters)))
                   (if (> ndebaters 1)
                       ;; Debates require two politicians
                       (let ((winner (pick-random debaters)))
                         (ask self 'SAY
                              (list "There are " (length candidates)
                                    " candidates in " (ask self 'NAME)
                                    "; " (length debaters) " will debate."))
                         (ask self 'SAY
                              (list (ask winner 'NAME)
                                    " won the debate."))
                         (for-each
                          (lambda (voter)
                            (ask voter 'WATCH-DEBATE debaters winner))
                          ((find-some 0.15) self 'VOTER?)))))))))
        (else (get-method message place))))))

(define (make&install-city name)
  (make&install-object make-city name))

;;; Implementation of people

(define (make-person name birthplace)
  (let ((phys-obj (make-physical-object name birthplace)))
    (lambda (message)
      (case message
        ((PERSON?)     (lambda (self) true))
        ((SAY)
         (lambda (self list-of-stuff)
           (delegate phys-obj self 'SAY
            (append (list "At" (ask (ask self 'LOCATION) 'NAME)
                          ":"  (ask self 'NAME) "says --")
                    (if (null? list-of-stuff)
                        '("Oh, nevermind.")
                        list-of-stuff)))))
        (else (get-method message phys-obj))))))

;;; 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*)

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

(define (make&install-object maker . args)
  (let ((object (apply maker args)))
    (ask object 'INSTALL)
    object))

(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-some what-fraction)
  (lambda (place predicate)
    ;; Try to get about WHAT-FRACTION of the objects that satisfy
    ;; PREDICATE from PLACE (but at least 3)
    (let ((all (find-all place predicate)))
      (if (null? all)
          '()
          (let ((n (length all)))
            (let ((desired (round (* n what-fraction))))
              (let ((desired-fraction (/ (min (max desired 3) n) n)))
                (filter (lambda (thing) (weighted-choice desired-fraction))
                        all))))))))

(define (find-some-no-limit what-fraction)
  (lambda (place predicate)
    ;; Try to get about WHAT-FRACTION of the objects that satisfy
    ;; PREDICATE from PLACE 
    (let ((all (find-all place predicate)))
      (if (null? all)
          '()
          (let ((n (length all)))
            (let ((desired (round (* n what-fraction))))
              (let ((desired-fraction (/ desired n)))
                (filter (lambda (thing) (weighted-choice desired-fraction))
                        all))))))))

(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

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