;;; ;;; object.ss ;;; CS200 Spring 2004 ;;; Problem Set 6 ;;; ;;; Simple object system with inheritance ;;; ;;; This code is loosely based on the code for MIT's 1997 Adventure Game. ;;; ;;; Version 1.0.2: Fixed problem in person 'take (delete parameters were in wrong ;;; order) ;;; Version 1.0.3: Revised for 2004. Changed meaning of restlessness. ;;; (display "Loading object.ss...") (define no-method #f) ;; All objects inherit from this, so we are guaranteed that any ;; object can respond to the messages object?, class, install, ;; name and say. (define make-object (lambda (name) (lambda (message) (if (eq? message 'object?) (lambda (self) #t) (if (eq? message 'class) (lambda (self) 'object) (if (eq? message 'name) (lambda (self) name) (if (eq? message 'say) (lambda (self list-of-stuff) (if (not (null? list-of-stuff)) (display-message list-of-stuff)) 'nuf-said) (if (eq? message 'install) (lambda (self . args) 'installed) #f)))))))) (define (make-object-sugared name) (lambda (message) (case message ((class) (lambda (self) 'object)) ((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 . args) 'installed)) (else no-method)))) ;;; ;;; get-method ;;; ;;; To get the method for a message, we just apply the object to that message. ;;; (define (get-method object message) (object message)) ;;; ;;; has-method? ;;; evaluates to #t iff the passed object has a method for handling the message ;;; (define (has-method? object message) (not (eq? no-method (get-method object message)))) (define (method? x) (cond ((procedure? x) #T) ((eq? x (no-method)) #F) (else (error "Object returned this non-message:" x)))) ;;; ;;; ask ;;; ;;; Send a message to an object (with optional arguments) ;;; (define (ask object message . args) (let ((method (get-method object message))) (if method (apply method object args) (begin (printf "A ~a does not know how to ~a~n" ;; We're in big trouble if something doesn't have name, if we use ask here! ((get-method object 'name) object) message) #f)))) ;;; ;;; is-a ;;; ;;; An object is-a property if it has a method named property, and ;;; (ask object property) evaluates to true. We can't just evaluate ;;; (ask object property), since the method might not exist if it ;;; is not one. ;;; (define (is-a object property) (if (has-method? object property) (ask object property) #f)) ;;; ;;; Constructing Places ;;; (define (make-place name) (let ((neighbor-map '()) ; Alist, direction -> object (things '()) (super (make-object name))) (lambda (message) (case message ((class) (lambda (self) 'place)) ((place?) (lambda (self) #t)) ((reset) (lambda (self) (set! neighbor-map '()) (set! things '()))) ((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)) #t)))) ((have-thing?) (lambda (self thing) (memq thing things))) ;; Following two methods should never be called by the player. ;; 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))) #t)) ((_del-thing!) (lambda (self thing) (cond ((not (ask self 'have-thing? thing)) (ask self 'say (list (ask thing 'name) " is no longer at " name))) (else (set! things (delete things thing)) ;; delete defined in listprocs.ss #t)))) ;;; Inherit all methods of object (else (get-method super message)))))) ;;; Physical objects have a location as well as a name (define null-place (make-place 'not-yet-installed)) (define (make-physical-object name) (let ((super (make-object name)) ;; instance variable (location null-place)) ; location set when we install (lambda (message) ; Normal actions (case message ((class) (lambda (self) 'physical-object)) ((physical-object?) (lambda (self) #t)) ((location) (lambda (self) location)) ((_set-location!) ;;; should not be called directly (lambda (self where) (set! location where))) ((install) (lambda (self where) (ask self 'say (list "Installing " (ask self 'name) " at " (ask where 'name))) (ask self '_set-location! where) (if (is-a where 'place?) (ask where '_add-thing! self) (ask self 'say (list (ask my-place 'name) "is not a location"))))) (else (get-method super message)))))) ;;; Mobile objects have a location that can change (define (make-mobile-object name) (let ((super (make-physical-object name))) (lambda (message) (case message ((class) (lambda (self) 'mobile-object)) ((mobile-object?) (lambda (self) #t)) ((change-location) (lambda (self new-place) (ask (ask self 'location) '_del-thing! self) (ask new-place '_add-thing! self) (ask self '_set-location! new-place))) (else (get-method super message)))))) ;;; ;;; Constructing things ;;; (define (make-thing name) (let ((super (make-mobile-object name)) (owner 'nobody)) (lambda (message) (case message ((class) (lambda (self) 'thing)) ((thing?) (lambda (self) #t)) ((owner) (lambda (self) owner)) ((owned?) (lambda (self) (not (eq? owner 'nobody)))) ;; The set-owner! 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 super message)))))) (define (ownable? object) (is-a object 'thing?)) ;;; Clock routines (define (make-world-clock) (let ((super (make-object 'world-clock)) (global-time 0) (clock-list null)) (lambda (message) (case message ((class) (lambda (self) 'world-clock)) ((add) (lambda (self object) (set! clock-list (cons object clock-list)) 'added)) ((remove) (lambda (self object) (delete clock-list object) 'removed)) ((time-of-day) (lambda (self) global-time)) ((tick) (lambda (self) (set! global-time (+ global-time 1)) (printf "[Clock] Tick ~a~n" global-time) (for-each (lambda (thing) (ask thing 'clock-tick)) clock-list) (newline) 'tick-tock)) ((run-clock) (lambda (self n) (n-times (lambda () (ask self 'tick)) n))) (else (get-method super message)))))) ;;; Does not put spaces between messages (define (display-message list-of-stuff) (for-each (lambda (s) (display s)) list-of-stuff) (newline) '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 (pick-random lst) (if (null? lst) #f (list-ref lst (random (length lst))))) ;; (list-ref lst k) evaluates to the kth element of the list lst ;;; ;;; filter is defined in listprocs.ss ;;; (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))) (define (other-people-at-place person place) (find-all-other place 'person? person)) ;;; ;;; People ;;; (define (make-person name) (let (;; A person is a kind of mobile object (super (make-mobile-object name)) ;; Instance variables (possessions '()) ;;; What the person is carrying (a list of Objects that are things (restlessness 0.0) ;;; How likely the person is to move randomly ) (lambda (message) (case message ((class) (lambda (self) 'person)) ((person?) (lambda (self) #t)) ((get-possessions) (lambda (self) possessions)) ((display-possessions) (lambda (self) (let ((my-stuff (ask self 'get-possessions))) (ask self 'say (cons "I have" (if (null? my-stuff) '("nothing") (map (lambda (p) (ask p 'name)) my-stuff)))) my-stuff))) ((say) (lambda (self list-of-stuff) (display-message (append (list "At " (ask (ask self 'location) 'name) ": " name " says -- ") (if (null? list-of-stuff) '("Oh, nevermind.") list-of-stuff))) 'said)) ((have-fit) (lambda (self) (ask self 'say '("Yaaaah! I am upset!")) 'I-feel-better-now)) ((look) (lambda (self) (let ((other-things ;;; Don't see yourself, so delete it from the things (map (lambda (sym) (string-append (symbol->string sym) " ")) (filter (lambda (name) (not (eq? name (ask self 'name)))) (map (lambda (thing) (ask thing 'name)) (ask (ask self 'location) 'things)))))) (ask self 'say (cons "I see " (if (null? other-things) '("nothing") other-things))) (ask self 'say (cons "I can go " (map (lambda (dir) (string-append (symbol->string dir) " ")) (ask (ask self 'location) 'exits)))) other-things))) ;;; Evaluate to the list of things ((take) (lambda (self thing) (cond ((member? thing possessions) (ask self 'say (list "I already have " (ask thing 'name))) #f) ((and (member? thing (ask (ask self 'location) 'things)) (ownable? thing)) (if (ask thing 'owned?) (let ((owner (ask thing 'owner))) (ask owner 'lose thing) 'unowned)) (ask thing 'set-owner! self) (set! possessions (cons thing possessions)) (ask self 'say (list "I take " (ask thing 'name))) #t) (else (display-message (list "You cannot take " (ask thing 'name))) #f)))) ((lose) (lambda (self thing) (if (eq? self (ask thing 'owner)) (begin (set! possessions (delete possessions thing)) (ask thing 'set-owner! 'nobody) (ask self 'say (list "I lose" (ask thing 'name))) (ask self 'have-fit)) #t) (begin (display-message (list name " does not own " (ask thing 'name))) #f))) ;;; Normal people are always dressed. ((is-dressed?) (lambda (self) #t)) ((make-restless) (lambda (self value) (set! restlessness value))) ((clock-tick) (lambda (self) (if (< (/ (random 100000) 100000) restlessness) (ask self 'act-randomly) #f))) ((act-randomly) (lambda (self) (let ((new-place (random-neighbor (ask self 'location)))) (if new-place (ask self 'move-to new-place) #f)))) ; No place to go ((move-to) (lambda (self new-place) (let ((old-place (ask self 'location)) (my-stuff (ask self 'get-possessions))) (define (greet-people person people) (if (not (null? people)) (ask person 'say (cons "Hi " (map (lambda (p) (string-append (symbol->string (ask p 'name)) " ")) people))) 'sure-is-lonely-in-here)) (cond ((is-a new-place 'place?) (display-message (list name " moves from " (ask old-place 'name) " to " (ask new-place 'name))) (ask self 'change-location new-place) (for-each (lambda (p) (ask p 'change-location new-place)) my-stuff) (greet-people self (other-people-at-place self new-place)) #t) (else (display-message (list name " can't move to " (ask new-place 'name)))))))) ((go) (lambda (self direction) (let ((old-place (ask self 'location))) (let ((new-place (ask old-place 'neighbor-towards direction))) (if new-place (ask self 'move-to new-place) (begin (display-message (list "You cannot go " direction " from " (ask old-place 'name))) #f)))))) (else (get-method super message)))))) (define (make-lecturer name) (let ((super (make-object name))) (lambda (message) (if (eq? message 'lecture) (lambda (self stuff) (ask self 'say stuff) (ask self 'say (list "you should be taking notes"))) (get-method super message))))) (display "done.") (newline)