;;; 
;;; game.ss
;;;

(define false #f)
(define true #t)

;;; Simple object system with inheritance

(define (ask object message . args) 
  (let ((method (get-method object message)))
    (if (method? method)
        (apply method (cons object args))
        (error "No method" message (cadr method)))))

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

(define (delegate-to to from message . args)
  ;; FROM wants TO to handle a message on its behalf
  ;; This assumed that *all* objects inherit from NAMED-OBJECT
  (let ((method (get-method to message)))
    (if (method? method)
        (apply method from args)
        (error "Can't delegate" message
               "from" (ask from 'name)
               "to" (ask to 'name)))))

(define (no-method name)
  (list 'no-method name))

(define (method? x)
  (not (no-method? x)))

(define (no-method? x)
  (if (pair? x)
      (eq? (car x) 'no-method)
      false))

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

(define (make-named-object name)
  (lambda (message) 
    (cond ((eq? message 'name) (lambda (self) name))
          ((eq? message 'say) (lambda (self stuff) (display stuff) (newline)))
          ((eq? message 'install) (lambda (self) 'ok))
          (else (no-method name)))))

;;; 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)
      (cond ((eq? message 'location) (lambda (self) location))
            ((eq? message 'install)
             (lambda (self)
               (ask location 'add-thing self)
               (delegate-to named-object self 'install))); Synchonize thing and place
            (else (get-method named-object message))))))

(define (make-mobile-object name location)
  (let ((physical-obj (make-physical-object name location)))
    (lambda (message)
      (cond ((eq? message 'place)    (lambda (self) location))
            ((eq? message 'location) (lambda (self) location))
            ;; Following method should never be called by the user...
            ;;  it is a system-internal method.
            ;; See CHANGE-LOCATION instead
            ((eq? message 'set-place)
             (lambda (self new-place)
               (set! location new-place)
               'place-set))
            ((eq? message 'change-location)
             (lambda (self new-place)
               (ask location 'del-thing self)
               (ask new-place 'add-thing self)
               (set! location new-place)))
            (else (get-method physical-obj message))))))

(define (make&install-mobile-object name place)
  (let ((mobile-obj (make-mobile-object name place)))
    (ask mobile-obj 'install)
    mobile-obj))

;;; Implementation of places

(define (make-place name)
  (let ((neighbors '())
        (neighbor-names '())
        (things       '())
        (named-obj (make-named-object name)))
    (lambda (message)
      (cond ((eq? message 'things) (lambda (self) things))
            ((eq? message 'neighbors)
             (lambda (self) neighbors))
            ((eq? message '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-PLACE instead.
            ((eq? message 'add-thing)
             (lambda (self new-thing)
               (cond ((memq new-thing things)
                      (display-message (list (ask new-thing 'name)
                                             "is already at" name))
                      false)
                     (else (set! things (cons new-thing things))
                           true))))
            ((eq? message 'del-thing)
             (lambda (self thing)
               (cond ((not (memq thing things))
                      (display-message (list (ask thing 'name)
                                             "is not at" name))
                      false)
                     (else (set! things (delq thing things))    ;; DELQ defined
                           true))))                             ;; below

            (else (get-method named-obj message))))))

;;; Cities are special kinds of places: debates happen there,
;;; and there are voters!

(define (make-city name)
  (let ((place (make-place name)))
    (lambda (message)
      (cond ((eq? message 'clock-tick)
             (lambda (self) (ask self 'sponsor-debate)))
            ((eq? message 'install)
             (lambda (self)
               (add-to-clock-list self)))
            ((eq? message '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 place message))))))

(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)
      (cond ((eq? message 'person?) (lambda (self) true))
            ((eq? message 'say) 
             (lambda (self list-of-stuff)
               (ask phys-obj '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 phys-obj message))))))

;;;; Special kinds of people

;;; Voters are people, even if the politicians and pollsters don't
;;; seem to think so.

(define (weighted-choice probability)
  ;; PROBABILITY is between 0 and 1
  (> probability (/ (random 11) 10.0)))

(define make-voter
  (let ((id 0))
    (lambda (voting-location how-initially-influencable noisy?)
      ;; How-initially-influencable: 0 -> can't be influenced
      ;;                             1 -> always influenced
      (let ((my-vote 'undecided)
            (how-influencable how-initially-influencable)
            (person (make-person 'anonymous-voter voting-location)))
        (define (voter message)
          (cond ((eq? message 'voter?) (lambda (self) true))
                ((eq? message 'id) (lambda (self) id))
                ((eq? message 'meet-candidate)
                 (lambda (self candidate)
                   (if noisy?
                       (ask self 'say
                            (list "Wow! I can't believe I'm talking to"
                                  (ask candidate 'name)
                                  "!!!  They've got my vote for sure.")))
                   (set! my-vote candidate)
                   (set! how-influencable (/ how-influencable 5))
                   true))
                ((eq? message 'vote)
                 (lambda (self candidates)
                   ;; Return any candidate (whether in the list CANDIDATES
                   ;; or not) or #F meaning refused to vote
                   (cond ((memq my-vote candidates) my-vote)
                         ((weighted-choice how-influencable)
                          (pick-random candidates))
                         ((or (eq? my-vote 'undecided)
                              (weighted-choice how-influencable))
                          false)
                         (else my-vote))))
                ((eq? message 'watch-debate)
                 (lambda (self debaters winner)
                   (cond ((eq? my-vote 'undecided)
                          (ask self 'reconsider winner 0.3))
                         ((eq? winner my-vote)
                          (if noisy?
                              (ask self 'say
                                   (list "Hey, my candidate just won the debate!")))
                          (set! how-influencable (/ how-influencable 2.0)))
                         ((memq my-vote debaters)
                          (if noisy?
                              (ask self 'say
                                   (list
                                    "My candidate can't even win a silly debate.")))
                          (set! how-influencable (min 1.0 (* how-influencable 2.0)))
                          (ask self 'reconsider winner 0.3))
                         (else
                          (if noisy?
                              (ask self 'say
                                   (list
                                    "My candidate wasn't invited to debate here.")))
                          (ask self 'reconsider winner 0.15)))
                   true))
                ((eq? message 'answer-poll)
                 (lambda (self choices)
                   ;; Return either one of the choices or 'UNDECIDED
                   (cond ((memq my-vote choices) my-vote)
                         ((weighted-choice how-influencable)
                          (pick-random choices))
                         (else 'undecided))))
                ((eq? message 'install)
                 (lambda (self)
                   (ask *the-registrar-of-voters* 'register-voter self)
                   (delegate-to person self 'install)))
                ((eq? message 'change-vote)
                 (lambda (self to-what)
                   (if noisy?
                       (ask self 'say (list "I've decided to change my vote to"
                                            (if (eq? to-what 'undecided)
                                                "undecided"
                                                (ask to-what 'name)))))
                   (set! my-vote to-what)
                   (set! how-influencable how-initially-influencable)
                   true))
            ((eq? message 'reconsider)
             (lambda (self whom influence-factor)
               ;; INFLUENCE-FACTOR is between -1 and 1
               (let ((probability
                      (max (min (+ how-influencable
                                   (* influence-factor
                                      how-influencable))
                                1.0)
                           0.0)))
                 (if (negative? influence-factor)
                     (if (and (eq? my-vote whom)
                              (weighted-choice probability))
                         (ask self 'change-vote 'undecided)
                         'done)
                     (cond ((eq? my-vote whom)
                            (if noisy?
                                (ask self 'say (list "I like" (ask whom 'name)
                                                     "more than ever.")))
                            (set! how-influencable probability))
                           ((eq? my-vote 'undecided)
                            (if (weighted-choice probability)
                                (ask self 'change-vote whom)
                                'done))
                           ((weighted-choice probability)
                            (ask self 'change-vote 'undecided))
                           (else 'done)))
                 'done)))
            (else (get-method person message))))
        (set! id (+ id 1))
        voter))))

(define (make&install-voter
         voting-location how-initially-influencable noisy?)
  (make&install-object
   make-voter voting-location how-initially-influencable noisy?))

;;; Travelling, by airplane or teleportation

(define make-plane 'LATER)

(define (make-traveller name initial-location)
  (let ((person (make-person name initial-location))
        (mobile-obj (make-mobile-object name initial-location)))
    (lambda (message)
      (cond ((eq? message 'install)
             (lambda (self)
               (delegate-to mobile-obj self 'install)))
            ((eq? message 'traveller?) (lambda (self) true))
            ((eq? message 'teleport) 
             (lambda (self)
               (let ((destination (pick-random *all-real-places*)))
                 (ask self 'change-location destination)
                 true)))
        ((eq? message 'travelling?)
         (lambda (self)
           ;; Returns true if a trip is in progress, false otherwise
           false))
        (else 
         (let ((mobile-meth (get-method mobile-obj message))
               (person-meth (get-method person message)))
           (if (method? mobile-meth)
               mobile-meth
               person-meth)))))))

(define (make-politician name initial-location thrill-seeking restlessness)
  ;; Thrill-seeking is a number between 0 and 1 that controls the
  ;; preference for teleportation over air transport as well as the
  ;; likelihood of participating in a debate.
  (let ((traveller (make-traveller name initial-location))
        (ticks-to-go restlessness))
    (lambda (message)
      (cond ((eq? message 'politician?) (lambda (self) true))
            ((eq? message 'clock-tick)
             (lambda (self)
               (cond ((ask self 'travelling?) 'done)
                     ((zero? ticks-to-go)
                      (set! ticks-to-go restlessness)
                      (ask self 'travel))
                     (else (set! ticks-to-go (- ticks-to-go 1))
                           (ask self 'campaign)))))
            ((eq? message 'travel)
             (lambda (self)
               (ask self 'teleport)))
            ((eq? message 'debate?) 
             (lambda (self) (weighted-choice thrill-seeking)))
            ((eq? message 'campaign)
             (lambda (self)
               (let ((where-am-i (ask self 'location)))
                 (let ((voters ((find-some 0.10) where-am-i 'voter?)))
                   (for-each
                    (lambda (voter) (ask voter 'meet-candidate self))
                    voters)))))
            ((eq? message 'install)
             (lambda (self)
               (delegate-to traveller self 'install)
               (ask *the-registrar-of-voters* 'register-candidate self)
               (add-to-clock-list self)))
        (else (get-method traveller message))))))

(define (make&install-politician
         name initial-location risk-aversion restlessness)
  (make&install-object
   make-politician name initial-location risk-aversion restlessness))

;;; --------------------------------------------------------------------------
;;; 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 ((= 0 n) 'done)
        (else (clock)
              (run-clock (- n 1)))))

;;; --------------------------------------------------------------------------
;;; 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 object property)))
    (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 1)))

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


;;; DrScheme doesn't include sort.  Following procedures included for sorting.

;;; (sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;;      (not (less? (list-ref list i) (list-ref list (- i 1)))).

(define (sorted? seq less?)
    (cond
         ((null? seq)
             #t)
         ((vector? seq)
             (let ((n (vector-length seq)))
                 (if (<= n 1)
                     #t
                     (do ((i 1 (+ i 1)))
                         ((or (= i n)
                              (less? (vector-ref seq (- i 1))
                                     (vector-ref seq i)))
                             (= i n)) )) ))
         (else
             (let loop ((last (car seq)) (next (cdr seq)))
                 (or (null? next)
                     (and (not (less? (car next) last))
                          (loop (car next) (cdr next)) )) )) ))


;;; (merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note:  this does _not_ accept vectors.  See below.

(define (merge a b less?)
    (cond
         ((null? a) b)
         ((null? b) a)
         (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
             ;; The loop handles the merging of non-empty lists.  It has
             ;; been written this way to save testing and car/cdring.
             (if (less? y x)
                 (if (null? b)
                     (cons y (cons x a))
                     (cons y (loop x a (car b) (cdr b)) ))
                 ;; x <= y
                 (if (null? a)
                     (cons x (cons y b))
                     (cons x (loop (car a) (cdr a) y b)) )) )) ))


;;; (merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note:  this does _not_ accept vectors.

(define (merge! a b less?)
    (define (loop r a b)
         (if (less? (car b) (car a))
             (begin
                 (set-cdr! r b)
                 (if (null? (cdr b))
                     (set-cdr! b a)
                     (loop b a (cdr b)) ))
             ;; (car a) <= (car b)
             (begin
                 (set-cdr! r a)
                 (if (null? (cdr a))
                     (set-cdr! a b)
                     (loop a (cdr a) b)) )) )
    (cond
         ((null? a) b)
         ((null? b) a)
         ((less? (car b) (car a))
             (if (null? (cdr b))
                 (set-cdr! b a)
                 (loop b a (cdr b)))
             b)
         (else ; (car a) <= (car b)
             (if (null? (cdr a))
                 (set-cdr! a b)
                 (loop a (cdr a) b))
             a)))

;;; (sort! sequence less?)
;;; sorts the list or vector sequence destructively.  It uses a version
;;; of merge-sort invented, to the best of my knowledge, by David H. D.
;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
;;; adapted it to work destructively in Scheme.
(define (sort! seq less?)
    (define (step n)
         (cond
             ((> n 2)
                 (let* ((j (quotient n 2))
                        (a (step j))
                        (k (- n j))
                        (b (step k)))
                     (merge! a b less?)))
             ((= n 2)
                 (let ((x (car seq))
                       (y (cadr seq))
                       (p seq))
                     (set! seq (cddr seq))
                     (if (less? y x) (begin
                         (set-car! p y)
                         (set-car! (cdr p) x)))
                     (set-cdr! (cdr p) '())
                     p))
             ((= n 1)
                 (let ((p seq))
                     (set! seq (cdr seq))
                     (set-cdr! p '())
                     p))
             (else
                 '()) ))
    (if (vector? seq)
         (let ((n (vector-length seq))
               (vector seq))                     ; save original vector
             (set! seq (vector->list seq))       ; convert to list
             (do ((p (step n) (cdr p))           ; sort list destructively
                  (i 0 (+ i 1)))                         ; and store elements back
                 ((null? p) vector)              ; in original vector
                 (vector-set! vector i (car p)) ))
         ;; otherwise, assume it is a list
         (step (length seq)) ))


;;; (sort sequence less?)
;;; sorts a vector or list non-destructively.  It does this by sorting a
;;; copy of the sequence
(define (sort seq less?)
    (if (vector? seq)
         (list->vector (sort! (vector->list seq) less?))
         (sort! (append seq '()) less?)))