;;;		     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 WORLD.SCM


;;;============================================================================
;;; You can extend this file to make more stuff part of your world.
;;;============================================================================

;;;============================================================================
;;; *CAVEAT* To keep your world consistent, whenever you change a procedure or 
;;;          redefine a person/place/etc you should reload this entire file    
;;;          into Scheme. This prevents you from having old-moldy folks running
;;;          around who have not evolved to adhere to your modifications. To   
;;;          make this work out well, you should create little scripts at the  
;;;          end of this file to make the game evolve as you work through it.  
;;;          [See the bottom of this file for an example.]                     
;;;============================================================================


(initialize-clock-list)

;; Here we define the places in our world...
;;------------------------------------------

(define Cambridge    (make&install-city 'Cambridge))
(define PaloAlto     (make&install-city 'PaloAlto))
(define Denver       (make&install-city 'Denver))
(define ElPaso       (make&install-city 'ElPaso))
(define Newton       (make&install-city 'Newton))
(define Philadelphia (make&install-city 'Philadelphia))
(define Bismark      (make&install-city 'Bismark))
(define Fairbanks    (make&install-city 'Fairbanks))
(define Kalamazoo    (make&install-city 'Kalamazoo))
(define WashingtonDC (make&install-city 'WashingtonDC))

(define *all-real-places*
  (list Cambridge PaloAlto Denver ElPaso Newton
	Philadelphia Bismark Fairbanks Kalamazoo WashingtonDC)) 

(define *the-sky* (make-place 'SOMEWHERE-OVER-THE-RAINBOW))


;; One-way paths connect individual places in the world.
;;------------------------------------------------------

(define (can-go from to)
  (ask from 'ADD-NEIGHBOR to))

(define (can-go-both-ways from to)
  (can-go from to)
  (can-go to from))

(define *connection-list*
  ;; Randomly generated list of air connections between cities
  (list (list cambridge paloalto denver bismark)
	(list paloalto denver fairbanks)
	(list denver paloalto philadelphia kalamazoo washingtondc)
	(list elpaso paloalto denver bismark)
	(list newton philadelphia fairbanks kalamazoo washingtondc)
	(list philadelphia elpaso kalamazoo)
	(list bismark denver fairbanks washingtondc)
	(list fairbanks)
	(list kalamazoo denver bismark)
	(list washingtondc paloalto philadelphia)))

;; Wire the cities together as shown above
(for-each
 (lambda (city-connections)
   (for-each
    (lambda (to-city)
      (can-go (car city-connections) to-city))
    (cdr city-connections)))
 *connection-list*)

(define (make-planes cities max-planes-per-route max-length-flight)
  (define (create-planes how-many from to duration)
    (if (zero? how-many)
	'DONE
	(begin
	  (make&install-plane from to duration)
	  (create-planes (- how-many 1) from to duration))))
  (for-each
   (lambda (from-city)
     (for-each
      (lambda (to-city)
	(let ((n-planes (random-number max-planes-per-route)))
	  (create-planes n-planes from-city to-city
			 (random-number max-length-flight))))
      (ask from-city 'NEIGHBORS)))
   cities))

(if (procedure? make-plane)
    ;; Part of the problem set is to define MAKE-PLANE
    (make-planes *all-real-places* 3 5)
    ;;(write-line (list "Don't forget to define MAKE-PLANE!"))
    )

;; The important critters in our world...
;;---------------------------------------

(define *the-registrar-of-voters*
  (let ((person (make-person '*Registrar* WashingtonDC))
	(candidates '())
	(voters '())
	(non-voters 0)
	(tally '()))
    (lambda (message)
      (case message
	((REGISTER-CANDIDATE)
	 (lambda (self candidate)
	   (set! candidates (cons candidate candidates))
	   true))
	((REGISTER-VOTER)
	 (lambda (self voter)
	   (set! voters (cons voter voters))
	   true))
	((TALLY)
	 (lambda (self active-candidates)
	   (set! tally
		 (map (lambda (candidate) (cons candidate 0))
		      active-candidates))
	   (set! non-voters 0)
	   (for-each
	      (lambda (voter)
		(let ((choice (ask voter 'VOTE active-candidates)))
		  (if choice
		      (let ((record (assq choice tally)))
			(if record
			    (set-cdr! record (+ 1 (cdr record)))
			    (set! tally (cons (cons choice 1)
					      tally))))
		      (set! non-voters (+ non-voters 1)))))
	      voters)
	   'TALLIED))

;;; *the-registrar-of-voters*, continues on the next page

;;; *the-registrar-of-voters*, continued
	((MERGE-RESULTS)
	 (lambda (self)
	   ;; Returns (((c1 c2 ..) v1) ((cn cm ...) v2) ...)
	   ;; Where v1 > v2 > ... > vn and
	   ;;       votes(c1)=votes(c2)=..., votes(cn)=votes(cm)=...
	   (let* ((sorted (sort tally
			       (lambda (r1 r2)
				 (> (cdr r1) (cdr r2)))))
		  (converted (map (lambda (r)
				    (cons (list (car r))
					  (cdr r)))
				  sorted)))
	     ;; CONVERTED has the correct output form, but all the
	     ;; entries have only one candidate in them.
	      (define (merge current rest)
		;; CURRENT is a guess at the correct next element for
		;; the output list -- it is either complete or needs
		;; to have another candidate added to it.
		(if (null? rest)
		    (list current)
		    (let* ((next (car rest))
			   (cvotes (cdr current))
			   (nvotes (cdr next)))
		      (if (= cvotes nvotes)
			  (merge (cons (append (car next)
					       (car current))
				       nvotes)
				 (cdr rest))
			  (cons current
				(merge next (cdr rest)))))))
	     (if (null? converted)
		 '()
		 (merge (car converted) (cdr converted))))))
	((REPORT-RESULTS)
	 (lambda (self winner-record)
	   (define (percentage fraction)
	     (/ (floor (* 10000.0 fraction)) 100.0))
	   (if (null? winner-record)
	       (ask self 'SAY (list "Nobody voted!"))
	       (let* ((winners (car winner-record))
		      (winner-votes (cdr winner-record))
		      (total-voters (length voters))
		      (turnout (percentage
				(/ (- total-voters non-voters)
				   total-voters))))
		 (if (null? (cdr winners))
		     (ask self 'SAY
			  (list "And the winner is ...."
				(ask (car winners) 'NAME)
				"with "
				(percentage (/ winner-votes total-voters))
				"percent of the votes cast, with"
				turnout "percent turnout."))
		     (ask self 'SAY
			  (list "Stalemate; all candidates received "
				winner-voters " with "
				turnout "percent turnout.")))))))

;;; *the-registrar-of-voters*, continues on the next page

;;; *the-registrar-of-voters*, continued

	((ELECTION)
	 (lambda (self)
	   (define (election-loop candidates)
	     (ask self 'SAY (list "Election between"
				  (map (lambda (c) (ask c 'NAME))
				       candidates)))
	     (ask self 'TALLY candidates)
	     (let ((merged (ask self 'MERGE-RESULTS)))
	       (if (null? merged)
		   (ask self 'REPORT-RESULTS merged)
		   (let ((winners (car (car merged))))
		     (if (and (not (null? (cdr merged)))
			      (not (null? (cdr winners))))
			 (election-loop winners)
			 (ask self 'REPORT-RESULTS (car merged)))))))
	   (election-loop candidates)))
	(else (get-method message person))))))

(define (create-voters max-per-city cities)
  (let ((total-voters 0))
    (for-each
     (lambda (city)
       (define (create-city-voters n-to-go)
	 (if (zero? n-to-go)
	     'DONE
	     (begin
	       (make&install-voter city
		 (/ (random 10000) 10000.0)
		 (= n-to-go 1)) ; One noisy voter
	       (create-city-voters (- n-to-go 1)))))
       (let ((n-voters (max 10 (random max-per-city))))
	 (set! total-voters (+ total-voters n-voters))
	 (display (ask city 'NAME))
	 (display " has ")
	 (display n-voters)
	 (display " voters.")
	 (newline)
	 (create-city-voters n-voters)))
     cities)
    (newline)
    (display "Total of ")
    (display total-voters)
    (display " voters.")
    (newline)
    total-voters))

(define (populate-reporters max-per-city cities)
  (let ((total-reporters 0))
    (for-each
     (lambda (city)
       (define (create-city-reporters n-to-go)
	 (if (zero? n-to-go)
	     'DONE
	     (begin
	       (make&install-reporter city .2 true)
	       (create-city-reporters (- n-to-go 1)))))
       (let ((n-reporters (max 1 (random max-per-city))))
	 (set! total-reporters (+ total-reporters n-reporters))
	 (display (ask city 'NAME))
	 (display " has ")
	 (display n-reporters)
	 (display " reporters.")
	 (newline)
	 (create-city-reporters n-reporters)))
     cities)
    (newline)
    (display "Total of ")
    (display total-reporters)
    (display " reporters.")
    (newline)
    total-reporters))


;;; some things that you will need to modify
;;;; 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 10000) 10000.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)
          (case message
            ((VOTER?) (lambda (self) true))
            ((ID) (lambda (self) id))
            ((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))
            ((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))
                      #F)
                     (else my-vote))))

;;; make-voter continues on the next page

;;; make-voter, continued
            ((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))
            ((WATCH-SOUNDBITE)
             (lambda (self politician quality)
               (cond ((eq? my-vote 'UNDECIDED)
                      (ask self 'RECONSIDER politician quality))
                     ((eq? politician my-vote)
                      (if noisy?
                          (ask self 'SAY
                               (list "Isn't" (ask politician 'name) "just dreamy!")))
                      (set! how-influencable (/ how-influencable 1.5)))
                     (else
                      (if noisy?
                          (ask self 'SAY
                               (list
                                "Hmm..." (ask politician 'name) "sure has a nice chin.")))
                      (set! how-influencable (min 1.0 (* how-influencable 1.5)))
                      (ask self 'RECONSIDER politician quality)))
               true))
            ((TAKE-BRIBE)
             (lambda (self politician quality)
               (cond ((eq? my-vote 'UNDECIDED)
                      (ask self 'RECONSIDER politician quality))
                     ((eq? politician my-vote)
                      (if noisy?
                          (ask self 'SAY
                               (list "I already like" (ask politician 'name) 
				     "... but I'll take your money anyways!")))
                      (set! how-influencable (/ how-influencable 1.5)))
                     (else
                      (if noisy?
                          (ask self 'SAY
                               (list "My my my..." (ask politician 'name) 
				     "is looking better and better!")))
                      (set! how-influencable (min 1.0 (* how-influencable 1.5)))
                      (ask self 'RECONSIDER politician quality)))
               true))
            ((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))))
            ((INSTALL)
             (lambda (self)
               (ask *the-registrar-of-voters* 'REGISTER-VOTER self)
               (delegate person self 'INSTALL)))
            ((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))

;;; make-voter continues on the next page

;;; make-voter, continued

            ((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 message person))))
        (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)
      (case message
        ((INSTALL)
         (lambda (self)
           (delegate-to-all (list person mobile-obj) self 'INSTALL)))
        ((TRAVELLER?) (lambda (s) true))
        ((TELEPORT)
         (lambda (self new-location)
	   (ask self 'CHANGE-LOCATION new-location)
	   true))
        (else (get-method message person mobile-obj))))))

(define (make-politician name initial-location)
  ;; 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))
	(state (make-state default-politician-state)))
    (lambda (message)
      (case message
	((POLITICIAN?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self)
	   (let ((current-manager (get self 'manager 1)))
	     (if current-manager
		 (ask current-manager 'WHAT-SHOULD-I-DO self)
		 (ask self 'PURCHASE-MANAGER)))))
	((PURCHASE-MANAGER)
	 (lambda (self)
	   (let ((purchased (ask *employment-office* 'purchase 'manager '())))
	     (let ((payable (ask self 'pay (get purchased 'price 1))))
	       (if payable
		   (begin
		     (ask purchased 'INSTALL)
		     (ask purchased 'CHANGE-LOCATION (ask self 'location))
		     (ask purchased 'set 'candidate self)
		     (ask self 'set 'manager purchased))
		   (ask self 'say '(Waaaahhhh!  I want my manager back!)))))))
	((TRAVEL)
	 (lambda (self)
	   (ask self 'TELEPORT)))
	((DEBATE?) (lambda (self) (weighted-choice (get self 'thrill-seeking 1))))
	((CAMPAIGN)
	 (lambda (self)
	   (let ((where-am-i (ask self 'LOCATION)))
	     (let ((reporters ((find-some-intelligently 0.3) where-am-i 'REPORTER?))
		   (voters ((find-some 0.10) where-am-i 'VOTER?))
		   (couch-potatoes ((find-some 0.30) where-am-i 'VOTER?))
		   (investigators
		    ((find-some 0.10) where-am-i 'SPECIAL-INVESTIGATOR?)))
	       (for-each
		(lambda (reporter) (ask reporter 'INTERVIEW self))
		reporters)
	       (if reporters ; there has been an interview
		   (for-each
		    (lambda (voter) (ask voter 'WATCH-SOUNDBITE self .1))
		    couch-potatoes))
	       (for-each
		(lambda (voter) (ask voter 'MEET-CANDIDATE self))
		voters)
	       (for-each
		(lambda (investigator)
		  (ask investigator 'NOT-ME self)) 
		investigators)))))
	((TELEPORT)
	 (lambda (self)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport)
	       (ask ghost 'say (list "Teleported from" (name-of old-place) 
				     "to" (name-of (ask self 'location))))))))
	((INTERVIEW)
	 (lambda (self)
	   (ask self 'say (pick-random *list-of-wit*))
	   'done))
	((PAY)
	 (lambda (self amount)
	   (let ((current-funds (get self 'money 1)))
	     (if (>= current-funds amount)
		 (begin
		   (ask self 'set 'money (- current-funds amount))
		   #t)
		 #f))))
	((EARN)
	 (lambda (self amount)
	   (let ((current-funds (get self 'money 1)))
	     (ask self 'set 'money (+ current-funds amount))
	     #t)))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (let ((manager (get self 'manager 1)))
	     (if manager
		 (ask manager 'set 'candidate #f)))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (ask *the-registrar-of-voters* 'REGISTER-CANDIDATE self)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))

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

(define (make&install-politician name initial-location)
  (make&install-object make-politician name initial-location))

(define *list-of-wit* '(("I am the eggman!")
			("I am not amused!")
			("I am sam I am!")))


;;; here are some simple  things that we can create to test our system

(define *all-politicians* 
  (map (lambda (name loc thrill restless)
	 (make&install-politician name loc thrill restless))
       '(a b c d e f g h i j k)
       (list Cambridge Cambridge Cambridge PaloAlto PaloAlto
	     Denver Denver Denver Denver Kalamazoo)
       (list 0.5 0.5 0.6 0.9 0.8
	     0.1 0.3 0.5 0.7 0.8)
       (list 5 2 3 1 5 6 2 5 3 4 6)))

(create-voters 15 *all-real-places*)

;;;;;;;;report.scm

(define (make-reporter voting-location how-initially-influencable noisy?)
  (let ((voter (make-voter voting-location how-initially-influencable noisy?)))
    (define (reporter message)
      (case message
	((REPORTER?) (lambda (self) true))
	((NAME) (lambda (self) 'anonymous-reporter))
	((INTERVIEW)
	 (lambda (self victim)
	   (ask self 'say (list "Let's see what" (ask victim 'name) "has to say!"))
	   (ask victim 'interview)))
	(else (get-method message voter))))
    reporter))

(define (make&install-reporter voting-location how-initially-influencable noisy?)
  (make&install-object make-reporter voting-location how-initially-influencable noisy?))

;;;;;pacster.scm
(define (make-pacster name initial-location restlessness candidate)
  (let ((traveller (make-traveller name initial-location))
	(ticks-to-go restlessness))
    (lambda (message)
      (case message
	((PACSTER?) (lambda (self) true))
	((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 'GREASE)))))
	((TRAVEL)
	 (lambda (self)
	   (ask self 'TELEPORT)))
	((INSTALL)
	 (lambda (self)
           (delegate traveller self 'INSTALL)
           (add-to-clock-list self)))
	((GREASE)
	 (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 'TAKE-BRIBE candidate .4))
                voters)))))
	(else (get-method message traveller))))))


(define (make&install-pacster name initial-location restlessness candidate)
  (make&install-object
   make-pacster name initial-location restlessness candidate))

***********Problem Set Extras********************

(define (find-some-intelligently what-fraction)
  (lambda (place predicate)
    (let ((all (find-all place predicate)))
      (if (null? all)
	  '()
	  (filter (lambda (thing) (weighted-choice what-fraction)) all)))))

*************Contest Extras**********************

****Location Fix****

(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))
	((MOVE-TO)
	 (lambda (self new-place)
	   (for-each
	    (lambda (item) (ask item 'move-to new-place))
	    (get self 'retinue 1))
	   (ask self 'change-location new-place)))
        ((CHANGE-LOCATION)
         (lambda (self new-place)
           (ask location 'DEL-THING self)
           (ask new-place 'ADD-THING self)
           (set! location new-place)
	   (ask self 'set 'loc new-place))) ;; Added this line to keep state updated
        (else (get-method message physical-obj))))))


(define (make-person name birthplace)
  (let ((mobile-obj (make-mobile-object name birthplace))) ;Altered people to be mobile objects
    (lambda (message)
      (case message
        ((PERSON?)     (lambda (self) true))
        ((SAY)
         (lambda (self list-of-stuff)
           (delegate mobile-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 mobile-obj))))))

****Traveller****


(define (make-traveller name initial-location)
  (let ((person (make-person name initial-location))
        (mobile-obj (make-mobile-object name initial-location)))
    (lambda (message)
      (case message
        ((INSTALL)
         (lambda (self)
           (delegate-to-all (list person mobile-obj) self 'INSTALL)))
        ((TRAVELLER?) (lambda (s) true))
        ((TELEPORT)
         (lambda (self new-location)
	   (ask self 'MOVE-TO new-location)
	   true))
        (else (get-method message person mobile-obj))))))


****Random Junk****

(define heck (make-place 'heck))

(define report display-message)


****Registrar Addition****


(define *the-registrar-of-voters*
  (let ((person (make-person '*Registrar* WashingtonDC))
	(candidates '())
	(voters '())
	(non-voters 0)
	(tally '()))
    (lambda (message)
      (case message
	((INITIALIZE)
	 (lambda (self)
	   (set! candidates '())
	   (set! voters '())
	   (set! non-voters 0)
	   (set! tally '())))
	((REGISTER-CANDIDATE)
	 (lambda (self candidate)
	   (set! candidates (cons candidate candidates))
	   true))
	((REMOVE-CANDIDATE)
	 (lambda (self candidate)
	   (set! candidates (delq candidate candidates))
	   true))
	((REGISTER-VOTER)
	 (lambda (self voter)
	   (set! voters (cons voter voters))
	   true))
	((TALLY)
	 (lambda (self active-candidates)
	   (set! tally
		 (map (lambda (candidate) (cons candidate 0))
		      candidates))
	   (set! non-voters 0)
	   (for-each
	      (lambda (voter)
		(let ((choice (ask voter 'VOTE active-candidates)))
		  (if choice
		      (let ((record (assq choice tally)))
			(if record
			    (set-cdr! record (+ 1 (cdr record)))
			    (set! tally (cons (cons choice 1)
					      tally))))
		      (set! non-voters (+ non-voters 1)))))
	      voters)
	   'TALLIED))
	((MERGE-RESULTS)
	 (lambda (self)
	   ;; Returns (((c1 c2 ..) v1) ((cn cm ...) v2) ...)
	   ;; Where v1 > v2 > ... > vn and
	   ;;       votes(c1)=votes(c2)=..., votes(cn)=votes(cm)=...
	   (let* ((sorted (sort tally
			       (lambda (r1 r2)
				 (> (cdr r1) (cdr r2)))))
		  (converted (map (lambda (r)
				    (cons (list (car r))
					  (cdr r)))
				  sorted)))
	     ;; CONVERTED has the correct output form, but all the
	     ;; entries have only one candidate in them.
	      (define (merge current rest)
		;; CURRENT is a guess at the correct next element for
		;; the output list -- it is either complete or needs
		;; to have another candidate added to it.
		(if (null? rest)
		    (list current)
		    (let* ((next (car rest))
			   (cvotes (cdr current))
			   (nvotes (cdr next)))
		      (if (= cvotes nvotes)
			  (merge (cons (append (car next)
					       (car current))
				       nvotes)
				 (cdr rest))
			  (cons current
				(merge next (cdr rest)))))))
	     (if (null? converted)
		 '()
		 (merge (car converted) (cdr converted))))))
	((REPORT-RESULTS)
	 (lambda (self winner-record)
	   (define (percentage fraction)
	     (/ (floor (* 10000.0 fraction)) 100.0))
	   (if (null? winner-record)
	       (ask self 'SAY (list "Nobody voted!"))
	       (let* ((winners (car winner-record))
		      (winner-votes (cdr winner-record))
		      (total-voters (length voters))
		      (turnout (percentage
				(/ (- total-voters non-voters)
				   total-voters))))
		 (if (null? (cdr winners))
		     (ask self 'SAY
			  (list "And the winner is ...."
				(ask (car winners) 'NAME)
				"with "
				(percentage (/ winner-votes total-voters))
				"percent of the votes cast, with"
				turnout "percent turnout."))
		     (ask self 'SAY
			  (list "Stalemate; all candidates received "
				winner-voters " with "
				turnout "percent turnout.")))))))
	((ELECTION)
	 (lambda (self)
	   (define (election-loop candidates)
	     (ask self 'SAY (list "Election between"
				  (map (lambda (c) (ask c 'NAME))
				       candidates)))
	     (ask self 'TALLY candidates)
	     (let ((merged (ask self 'MERGE-RESULTS)))
	       (if (null? merged)
		   (ask self 'REPORT-RESULTS merged)
		   (let ((winners (car (car merged))))
		     (if (and (not (null? (cdr merged)))
			      (not (null? (cdr winners))))
			 (election-loop winners)
			 (ask self 'REPORT-RESULTS (car merged)))))))
	   (election-loop candidates)))
	(else (get-method message person))))))


****State****

(define (make-state initial-state)
  (let ((state-variables (make-copy-of initial-state))
	(flag #f))
    (lambda (message)
      (case message
       ((SET)
	(lambda (self state value)
	  (set! flag #f)
	  (map
	   (lambda (x)
	     (cond ((eq? state (car x))
		    (set-car! (cdr x) value)
		    (set! flag #t))))
	   state-variables)
	  (if flag
	      'set
	      (set! state-variables (cons (list state value 0) 
					  state-variables)))))
       ((SET-SECURITY)
	(lambda (self state value)
	  (map
	   (lambda (x)
	     (cond ((eq? state (car x))
		    (set-car! (cddr x) value))))
	   state-variables)))
       ((BECOME)
	(lambda (self . state)
	  (cond
	   ((eq? (car state) 'not)
	    (ask self 'set (cadr state) #f))
	   (else
	    (ask self 'set (car state) #t)))))
       ((GET-SECURITY)
	(lambda (self state)
	  (let ((particular-state (filter
				   (lambda (x) (eq? (symbol-of x) state))
				   state-variables)))
	    (if (null? particular-state)
		#f
		(security-of (car particular-state))))))
       (else
	(let ((particular-state (filter
				 (lambda (x) (eq? (symbol-of x) message))
				 state-variables)))
	  (if (null? particular-state)
	      (no-method)
	      (lambda (self security) 
		(if (>= security (security-of (car particular-state)))
		    (value-of (car particular-state))
		    #f)))))))))

(define security-of caddr)

(define value-of cadr)

(define symbol-of car)

(define (default-politician-state)
  (list (list 'speech-quality (/ (random 5) 10) 0)
    (list 'debate-quality (/ (random 5) 10) 0)
    (list 'thrill-seeking (/ (random 5) 10) 0)
    (list 'money (random 500) .2)
    (list 'thac0 (+ 20 (random 20)) .6)
    (list 'ac (random 10) .6)
    '(loc () 0)
    '(assassins () .9)
    '(bodyguards () .2)
    '(erasers () .9)
    (list 'street-smart (/ (random 4) 10) .2)))

(define (default-manager-state)
  (list '(ruthlessness .1 .4)
    (list 'restlessness (random 15) .1)
    (list 'ticks-to-go 6 .1)
    (list 'thac0 (+ 20 (random 20)) .6)
    (list 'ac (random 10) .6)
    '(loc () .1)
    '(assassins () .9)
    '(bodyguards () .2)
    '(erasers () .9)
    (list 'street-smart (/ (random 8) 10) .4)))

(define (default-assassin-state)
  (list (list 'thac0 (+ 10 (random 10)) .7)
    (list 'ac (- (random 10) 5) .7)
    '(loc () .5)
    '(target () .6)
    '(assassins () .9)
    '(bodyguards () .2)
    '(erasers () .9)
    (list 'street-smart (/ (random 8) 10) .6)))

(define (default-bodyguard-state)
  (list (list 'thac0 (+ 15 (random 10)) .7)
    (list 'ac (random 10) .7)
    '(loc () .5)
    '(assassins '() .9)
    '(bodyguards '() .2)
    '(erasers () .9)
    (list 'street-smart (/ (random 5) 10) .6)))

(define (default-eraser-state)
  (list (list 'thac0 (+ 15 (random 10)) .7)
    (list 'ac (random 10) .7)
    '(loc () .5)
    '(assassins '() .9)
    '(bodyguards '() .2)
    '(erasers () .9)
    (list 'street-smart (/ (random 5) 10) .6)))

(define (make-copy-of lst)
  (cond ((null? lst) '())
	((not (pair? lst)) lst)
	(else
	 (cons (make-copy-of (car lst)) (make-copy-of (cdr lst))))))

****Politicians****

(define (make-politician name initial-location)
  ;; 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))
	(state (make-state (default-politician-state))))
    (lambda (message)
      (case message
	((POLITICIAN?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self)
	   (let ((travelling (get self 'travelling 1)))
	     (cond ((and travelling (not (= 0 travelling)))
		    (ask self 'set 'travelling (- travelling 1)))
		   (else
		    (let ((current-manager (get self 'manager 1)))
		      (if current-manager
			  (ask current-manager 'WHAT-SHOULD-I-DO self)
			  (ask self 'PURCHASE-MANAGER))))))))
	((PURCHASE-MANAGER)
	 (lambda (self)
	   (let ((purchased (ask *employment-office* 'purchase 'manager '())))
	     (let ((payable (ask self 'pay (get purchased 'price 1))))
	       (if payable
		   (begin
		     (ask purchased 'INSTALL)
		     (ask purchased 'CHANGE-LOCATION (ask self 'location))
		     (ask purchased 'set 'candidate self)
		     (ask self 'set 'retinue (cons purchased (get self 'retinue 1)))
		     (ask self 'set 'manager purchased))
		   (ask self 'say '(Waaaahhhh!  I want my manager back!)))))))
	((DEBATE?) (lambda (self) (weighted-choice (get self 'thrill-seeking 1))))
	((CAMPAIGN)
	 (lambda (self)
	   (let ((where-am-i (ask self 'LOCATION)))
	     (let ((reporters ((find-some-intelligently 0.3) where-am-i 'REPORTER?))
		   (voters ((find-some 0.10) where-am-i 'VOTER?))
		   (couch-potatoes ((find-some 0.30) where-am-i 'VOTER?))
		   (investigators
		    ((find-some 0.10) where-am-i 'SPECIAL-INVESTIGATOR?)))
	       (for-each
		(lambda (reporter) (ask reporter 'INTERVIEW self))
		reporters)
	       (if reporters ; there has been an interview
		   (for-each
		    (lambda (voter) (ask voter 'WATCH-SOUNDBITE self .1))
		    couch-potatoes))
	       (for-each
		(lambda (voter) (ask voter 'MEET-CANDIDATE self))
		voters)
	       (for-each
		(lambda (investigator)
		  (ask investigator 'NOT-ME self)) 
		investigators)))))
	((TRAVEL)
	 (lambda (self)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport)
	       (ask self 'set 'travelling 3)
	       (ask ghost 'say (list "Teleported from" (name-of old-place) 
				     "to" (name-of (ask self 'location))))))))
	((INTERVIEW)
	 (lambda (self)
	   (ask self 'say (pick-random *list-of-wit*))
	   'done))
	((PAY)
	 (lambda (self amount)
	   (let ((current-funds (get self 'money 1)))
	     (if (>= current-funds amount)
		 (begin
		   (ask self 'set 'money (- current-funds amount))
		   #t)
		 #f))))
	((EARN)
	 (lambda (self amount)
	   (let ((current-funds (get self 'money 1)))
	     (ask self 'set 'money (+ current-funds amount))
	     #t)))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (ask *the-registrar-of-voters* 'REMOVE-CANDIDATE self)
	   (let ((manager (get self 'manager 1))
		 (erasers (get self 'erasers 1))
		 (assassins (get self 'assassins 1))
		 (bodyguards (get self 'bodyguards 1)))
	     (if assassins
		 (for-each
		  (lambda (assassin) (ask assassin 'set 'target #f))
		  assassins))
	     (if erasers
		 (for-each
		  (lambda (eraser) (ask eraser 'set 'fledgling #f))
		  erasers))
	     (if bodyguards
		 (for-each
		  (lambda (bodyguard) (ask bodyguard 'set 'fledgling #f))
		  bodyguards))
	     (if manager
		 (ask manager 'set 'candidate #f)))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (ask *the-registrar-of-voters* 'REGISTER-CANDIDATE self)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))


****Managers****

(define (make-manager name initial-location managing-code)
  (let ((traveller (make-traveller name initial-location))
	(state (make-state (default-manager-state))))
    (lambda (message)
      (case message
	((MANAGER?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self) #t))
	((WHAT-SHOULD-I-DO)
	 managing-code)
	((TRAVEL)
	 (lambda (self new-location)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport new-location)
	       (ask self 'set 'travelling 3)
	       (ask ghost 'say (list "Teleporting from" (name-of old-place) 
				     "to" (name-of (ask self 'location))))))))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (let ((candidate (get self 'candidate 1))
		 (erasers (get self 'erasers 1))
		 (assassins (get self 'assassins 1))
		 (bodyguards (get self 'bodyguards 1)))
	     (if assassins
		 (for-each
		  (lambda (assassin) (ask assassin 'set 'target #f))
		  assassins))
	     (if erasers
		 (for-each
		  (lambda (eraser) (ask eraser 'set 'fledgling #f))
		  erasers))
	     (if bodyguards
		 (for-each
		  (lambda (bodyguard) (ask bodyguard 'set 'fledgling #f))
		  bodyguards))
	     (if candidate
		 (ask candidate 'set 'manager #f)))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))

(define (make&install-manager name initial-location managing-code)
  (make&install-object make-manager name initial-location managing-code))


****Managing Codes****

(define (apathy self pawn) #t)

(define (boring self pawn) (ask pawn 'CAMPAIGN))

(define ruthless
  (let ((foo 'bar))
    (define (send-assassin self pawn victim)
      (let ((purchased (ask *employment-office* 'PURCHASE 'ASSASSIN '())))
	(let ((payable (ask pawn 'PAY (get purchased 'price 1))))
	  (if (not payable)
	      #f
	      (begin
		(ask purchased 'INSTALL)
		(ask purchased 'CHANGE-LOCATION (ask pawn 'LOCATION))
		(ask purchased 'INSTALL-TARGET victim)
		(ask self 'set 'ass-list (cons (cons purchased victim) (get self 'ass-list 1)))
		(ask purchased 'set 'boss self)
		#t)))))
    (lambda (self pawn)
      (let ((the-results (ask *the-registrar-of-voters* 'merge-results)))
	(if (not the-results)
	    (ask pawn 'CAMPAIGN)   ;How boring...  There's no one to kill...
	    (let ((number-one (caaar the-results)))
	      (if (not (eq? number-one pawn))
		  (send-assassin self pawn number-one) ;Ah yeah!  Take out number one!
		  (if (null? (cdr the-results))
		      (ask pawn 'CAMPAIGN)  ;How boring...  There's no one here but me...
		      (let ((number-two (caaadr the-results)))
			(send-assassin self pawn number-two)))))))))) ;Ah yeah!

(define (defensive self pawn)
  (let ((purchased (ask *employment-office* 'PURCHASE 'BODYGUARD '())))
    (let ((payable (ask pawn 'PAY (get purchased 'price 1))))
      (if (not payable)
	  (ask pawn 'CAMPAIGN)
	  (begin
	    (ask purchased 'INSTALL)
	    (ask purchased 'CHANGE-LOCATION (ask pawn 'LOCATION))
	    (ask purchased 'INSTALL-FLEDGLING pawn)
	    (ask self 'set 'body-list (cons purchased (get self 'body-list 1)))
	    (ask purchased 'set 'boss self)
	    (ask pawn 'CAMPAIGN)
	    #t)))))


****Test Managing****

(define test-list-of-candidates 'foobar)

(define (initialize-test-environment)
  (initialize-clock-list)
  (ask *the-registrar-of-voters* 'INITIALIZE) 
  (define dev-null (make-place 'dev-null))
  (define dev-zero (make-place 'dev-zero))
  (define dev-one (make-place 'dev-one))
  (define bob-apathetic (make&install-politician 'bob-apathetic dev-null))
  (define bob-boring (make&install-politician 'bob-boring dev-null))
  (define bob-ruthless (make&install-politician 'bob-ruthless dev-zero))
  (define bob-defensive (make&install-politician 'bob-defensive dev-one))
  (create-voters 5 (list dev-null dev-zero dev-one))
  (define man-apathetic (make&install-manager 'man-apathetic dev-null apathy))
  (define man-boring (make&install-manager 'man-boring dev-null boring))
  (define man-ruthless (make&install-manager 'man-ruthless dev-zero ruthless))
  (define man-defensive (make&install-manager 'man-defensive dev-one defensive))
  (ask bob-apathetic 'set 'manager man-apathetic)
  (ask man-apathetic 'set 'candidate bob-apathetic)
  (ask bob-boring 'set 'manager man-boring)
  (ask man-boring 'set 'candidate bob-boring)
  (ask bob-ruthless 'set 'manager man-ruthless)
  (ask man-ruthless 'set 'candidate bob-ruthless)
  (ask bob-defensive 'set 'manager man-defensive)
  (ask man-defensive 'set 'candidate bob-defensive)

  (set! test-list-of-candidates (list bob-apathetic bob-boring bob-ruthless bob-defensive))

  (run-clock 10)

  (ask *the-registrar-of-voters* 'ELECTION))

****Clock Hack****

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

  
****Employment Office****

(define (*employment-office* message)
  (case message
    ((PURCHASE)
     (lambda (self item specifications)
       (case item
	 ((MANAGER)
	  (let loop ((count 0))
	    (let ((manager (make-manager (pick-random list-of-man-names) dev-null 
					 (pick-random list-of-codes))))
	      (if (and specifications
		       (< (get manager (car specifications) 1) (cdr specifications))
		       (< count 40))
		  (loop (+ count 1))
		  (begin
		    (ask manager 'set 'price (+ 70 (* 10 count)))
		    manager)))))
	 ((POLITICIAN)
	  (let loop ((count 0))
	    (let ((politician (make-politician (pick-random list-of-pol-names) dev-null)))
	      (if (and specifications
		       (< (get politician (car specifications) 1) (cdr specifications))
		       (< count 40))
		  (loop (+ count 1))
		  (begin
		    (ask politician 'set 'price (+ 60 (* 15 count)))
		    politician)))))
	 ((ASSASSIN)
	  (let loop ((count 0))
	    (let ((assassin (make-assassin (pick-random list-of-ass-names) dev-null)))
	      (if (and specifications
		       (< (get assassin (car specifications) 1) (cdr specifications))
		       (< count 40))
		  (loop (+ count 1))
		  (begin
		    (ask assassin 'set 'price (+ 60 (* 10 count)))
		    assassin)))))
	 ((ERASER)
	  (let loop ((count 0))
	    (let ((eraser (make-eraser (pick-random list-of-er-names) dev-null)))
	      (if (and specifications
		       (< (get eraser (car specifications) 1) (cdr specifications))
		       (< count 40))
		  (loop (+ count 1))
		  (begin
		    (ask eraser 'set 'price (+ 70 (* 10 count)))
		    eraser)))))
	 ((BODYGUARD)
	  (let loop ((count 0))
	    (let ((bodyguard (make-bodyguard (pick-random list-of-body-names) dev-null)))
	      (if (and specifications
		       (< (get bodyguard (car specifications) 1) (cdr specifications))
		       (< count 40))
		  (loop (+ count 1))
		  (begin
		    (ask bodyguard 'set 'price (+ 50 (* 10 count)))
		    bodyguard)))))
	 (else
	  'Bogus-item!))))
    (else (no-method))))

(define list-of-man-names
  (list "Bill_Gates" "NRA" "Green_Peace" "John_Galt" "The_Wizard_of_Oz"))

(define list-of-pol-names
  (list "Bob" "Yakhtoe" "Billy-bob" "Olly_North" "Gary_Kasparov"))

(define list-of-ass-names
  (list "Mr._X" "Victor_the_Cleaner" "Oswald" "Rose" "The_Gray_Man" "Nighthawk" "Wolfe"))

(define list-of-er-names
  (list "Schwarzy" "Arnie" "Silvy" "Blank_Check" "Faceless"))

(define list-of-body-names
  (list "Costner" "Thug" "Slug" "Chug" "Lug" "Mug" "Splug" "Glug" "Fug" "Bug"))

(define list-of-codes
  (list apathy boring ruthless))

****Assassins****

(define (make-assassin name initial-location)
  (let ((traveller (make-traveller name initial-location))
	(state (make-state (default-assassin-state))))
    (lambda (message)
      (case message
	((ASSASSIN?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self)
	   (let ((travelling (get self 'travelling 1)))
	     (cond ((and travelling (not (= 0 travelling)))
		    (ask self 'set 'travelling (- travelling 1)))
		   (else
		    (let ((target (get self 'target 1))
			  (street-smart (get self 'street-smart 1)))
		      (if (not target)
			  (ask self 'say (list "Man I'm bored!"))
			  (let ((target-loc (get target 'loc street-smart)))
			    (if (not target-loc)
				(ask self 'say (list "Hey, where did he go!?"))
				(if (eqv? target-loc (ask self 'location))
				    (ask self 'kill)
				    (ask self 'travel target-loc)))))))))))
	((KILL)
	 (lambda (self)
	   (let ((target (get self 'target 1))
		 (thac0 (get self 'thac0 1))
		 (ac (get self 'ac 1)))
	     (let ((opp-thac0 (get target 'thac0 1))
		   (opp-ac (get target 'ac 1)))
	       (let ((roll-1 (+ 1 (random 20)))
		     (roll-2 (+ 1 (random 20))))
		 (if (or (= 20 roll-1) (> roll-1 (- thac0 opp-ac)))
		     (begin
		       (ask target 'die)
		       (ask self 'say (list "Ah yeah!  Take that" 
					    (name-of target)))
		       (report (list "At" (name-of (ask self 'location)) ":" (ask self 'name) 
				     "killed" (ask target 'name)))
		       (let ((boss (get self 'boss 1)))
			 (if boss
			  ;   (ask boss 'WHAT-SHOULD-I-DO self)))
			     #t))
		       (ask self 'set 'target #f))
		     (ask self 'say (list "Ah fuck, I missed"
					  (name-of target))))
		 (if (or (= 20 roll-1) (> roll-1 (- opp-thac0 ac)))
		     (begin
		       (ask self 'say (list "()#!&@#!!"))
		       (report (list "At" (name-of (ask self 'location)) ":" (ask target 'name) 
				     "killed" (ask self 'name)))
		       (ask self 'die))
		     'Nyah-nyah!))))))
	((INSTALL-TARGET)
	 (lambda (self target)
	   (ask self 'set 'target target)
	   (let ((assassins (get target 'assassins 1)))
	     (ask target 'set 'assassins (cons self assassins)))))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (let ((target (get self 'target 1))
		 (erasers (get self 'erasers 1))
		 (assassins (get self 'assassins 1))
		 (bodyguards (get self 'bodyguards 1)))
	     (if assassins
		 (for-each
		  (lambda (assassin) (ask assassin 'set 'target #f))
		  assassins))
	     (if erasers
		 (for-each
		  (lambda (eraser) (ask eraser 'set 'fledgling #f))
		  erasers))
	     (if bodyguards
		 (for-each
		  (lambda (bodyguard) (ask bodyguard 'set 'fledgling #f))
		  bodyguards))
	     (if target
		 (let ((target-assassins (get target 'assassins 1)))
		   (if target-assassins
		       (ask target 'set 'assassins (delq self target-assassins))))))))
	((TRAVEL)
	 (lambda (self new-location)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport new-location)
	       (ask self 'set 'travelling 3)
	       (ask ghost 'say (list "Teleporting from" (name-of old-place) 
				     "to" (name-of (ask self 'location))
				     "in search of" (name-of (get self 'target 1))))))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))

(define (make&install-assassin name initial-location)
  (make&install-object make-assassin name initial-location))


****Body Guard****

(define (make-bodyguard name initial-location)
  (let ((traveller (make-traveller name initial-location))
	(state (make-state (default-bodyguard-state))))
    (lambda (message)
      (case message
	((ASSASSIN?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self)
	   (let ((travelling (get self 'travelling 1)))
	     (cond ((and travelling (not (= 0 travelling)))
		    (ask self 'set 'travelling (- travelling 1)))
		   (else
		    (ask self 'say (list "Grunt...")))))))
	((INSTALL-FLEDGLING)
	 (lambda (self fledgling)
	   (ask self 'set 'fledgling fledgling)
	   (let ((fledge-ac (get fledgling 'ac 1))
		 (fledge-thac0 (get fledgling 'thac0 1))
		 (fledge-retinue (get fledgling 'retinue 1))
		 (fledge-bodyguards (get fledgling 'bodyguards 1)))
	     (ask fledgling 'set 'ac (- fledge-ac 3))
	     (ask fledgling 'set 'thac0 (- fledge-thac0 3))
	     (ask fledgling 'set 'bodyguards (cons self fledge-bodyguards))
	     (ask fledgling 'set 'retinue (cons self fledge-retinue)))
	   (ask self 'move-to (ask fledgling 'location))))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (let ((fledge-bodyguards (get target 'bodyguards 1))
		 (erasers (get self 'erasers 1))
		 (assassins (get self 'assassins 1))
		 (bodyguards (get self 'bodyguards 1)))
	     (if assassins
		 (for-each
		  (lambda (assassin) (ask assassin 'set 'target #f))
		  assassins))
	     (if erasers
		 (for-each
		  (lambda (eraser) (ask eraser 'set 'fledgling #f))
		  erasers))
	     (if bodyguards
		 (for-each
		  (lambda (bodyguard) (ask bodyguard 'set 'fledgling #f))
		  bodyguards))
	     (if fledge-bodyguards
		 (ask target 'set 'bodyguards (delq self fledge-bodyguards))))))
	((TRAVEL)
	 (lambda (self new-location)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport new-location)
	       (ask self 'set 'travelling 3)
	       (ask ghost 'say (list "Teleporting from" (name-of old-place) 
				     "to" (name-of (ask self 'location))))))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))

(define (make&install-bodyguard name initial-location)
  (make&install-object make-bodyguard name initial-location))


****Eraser****

(define (make-eraser name initial-location)
  (let ((traveller (make-traveller name initial-location))
	(state (make-state (default-bodyguard-state))))
    (lambda (message)
      (case message
	((ERASER?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self)
	   (let ((travelling (get self 'travelling 1)))
	     (cond ((and travelling (not (= 0 travelling)))
		    (ask self 'set 'travelling (- travelling 1)))
		   (else
		    (ask self 'say (list "I'll be back...")))))))
	((INSTALL-FLEDGLING)
	 (lambda (self fledgling)
	   (ask self 'set 'fledgling fledgling)
	   (let ((fledge-loc-sec (ask fledgling 'get-security 'loc))
		 (fledge-erasers (get fledgling 'erasers 1)))
	     (ask fledgling 'set-security 'loc (MAX 1 (+ fledge-loc-sec .3)))
	     (ask fledgling 'become 'under-cover)
	     (ask fledgling 'set 'erasers (cons self fledge-erasers))
	     (ask fledgling 'set 'retinue (cons self fledge-retinue)))
	   (ask self 'move-to (ask fledgling 'location))))
	((LOSE-COVER)
	 (lambda (self)
	   (let ((fledgling (get self 'fledgling 1)))
	     (if (not fledgling)
		 'Not-important
		 (let ((fledge-loc-sec (ask fledgling 'get-security 'loc)))
		   (ask fledgling 'set-security 'loc (- fledge-loc-sec .3))
		   (ask fledgling 'become 'not 'under-cover))))))
	((RESTORE-COVER)
	 (lambda (self)
	   (let ((fledgling (get self 'fledgling 1)))
	     (if (not fledgling)
		 'Not-important
		 (let ((fledge-loc-sec (ask fledgling 'get-security 'loc)))
		   (ask fledgling 'set-security 'loc (MAX 1 (- fledge-loc-sec .3)))
		   (ask fledgling 'become 'under-cover))))))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (let ((fledgling (get self 'fledgling 1))
		 (assassins (get self 'assassins 1))
		 (erasers (get self 'erasers 1))
		 (bodyguards (get self 'bodyguards 1)))
	     (if assassins
		 (for-each
		  (lambda (assassin) (ask assassin 'set 'target #f))
		  assassins))
	     (if erasers
		 (for-each
		  (lambda (eraser) (ask eraser 'set 'fledgling #f))
		  erasers))
	     (if bodyguards
		 (for-each
		  (lambda (bodyguard) (ask bodyguard 'set 'fledgling #f))
		  bodyguards))
	     (if fledgling
		 (let ((fledge-erasers (get fledling 'erasers 1)))
		   (ask fledgling 'set 'erasers (delq self fledge-erasers)))))))
	((TRAVEL)
	 (lambda (self new-location)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport new-location)
	       (ask self 'set 'travelling 3)
	       (ask ghost 'say (list "Teleporting from" (name-of old-place) 
				     "to" (name-of (ask self 'location))))))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))

(define (make&install-eraser name initial-location)
  (make&install-object make-eraser name initial-location))


****The Informer****

(define nirvana (make-place 'nirvana))

(define the-informer-guard (make&install-bodyguard 'the-informer-guard nirvana))

(define the-informer-state
  (list '(thac0 5 .7)
	'(ac -3 .7)
	(list 'loc #f nirvana)
	'(assassins '() .9)
	(list 'bodyguards (list the-informer-guard) .2)
	'(street-smart 1 0)))

(define the-informer
  (let ((traveller (make-traveller 'the-informer nirvana))
	(state (make-state the-informer-state)))
    (lambda (message)
      (case message
	((INFORMER?) (lambda (self) true))
	((CLOCK-TICK)
	 (lambda (self)
	   (let ((travelling (get self 'travelling 1)))
	     (cond ((and travelling (not (= 0 travelling)))
		    (ask self 'set 'travelling (- travelling 1)))
		   (else
		    (ask self 'say (list "Nyah, I don't know nothing...")))))))
	((DIE)
	 (lambda (self)
	   (ask self 'CHANGE-LOCATION heck)
	   (remove-from-clock-list self)
	   (ask self 'become 'dead)))
	((GET-INFO)
	 (lambda (self quality-of-info)
	   (if (get self 'dead 1)
	       2222
	       (* quality-of-info 100))))
	((TRAVEL)
	 (lambda (self new-location)
	   (let ((old-place (ask self 'location)))
	     (let ((ghost (make-person (ask self 'name) old-place)))
	       (delegate traveller self 'teleport new-location)
	       (ask self 'set 'travelling 3)
	       (ask ghost 'say (list "Teleporting from" (name-of old-place) 
				     "to" (name-of (ask self 'location))))))))
	((INSTALL)
	 (lambda (self)
	   (ask self 'set 'loc (ask self 'location))
	   (delegate traveller self 'INSTALL)
	   (add-to-clock-list self)))
	(else (get-method message traveller state))))))

(ask the-informer 'INSTALL)