Scheme+Betty Example: A MUD-like game

This was Problem Set 5 for Cornell's CS212, Spring 1994. It's a MUD-like game that mirrored lots of real-life places on campus. It's like a little time capsule!

Index

load.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; LOAD.BETTY ;;; Loads the entire adventure game (except the solutions/modification file) ;;; ;;; You CANNOT modify this file in any way. ;;; ;;; The only restriction when loading the files manually is that "game.betty" ;;; must be loaded first and actions.betty comes after interactive.betty. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (begin (load "game.betty") (load "place.betty") (load "item.betty") (load "animate.betty") (load "interactive.betty") (load "actions.betty") (load "solutions.betty") (string->symbol ""))

game.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GAME.BETTY ;;; Basics for the entire adventure game. ;;; ;;; You CANNOT modify this file in any way. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The macro sanity is used for error checking throughout the code. ;;; (macro sanity (function ((<list> args)) (if (pair? (cdr args)) `(if (not ,(cadr args)) (cerror "Sanity check failed." ,@(cddr args))) (cerror "Wrong number of arguments to macro sanity." (cdr args))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Manipulation of the world ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The global varibles, *WORLD*, *ITEMS*, *CLOCK*, *NOWHERE*. ;;; ;;; *WORLD* is a list of all the places in the world. (global (list-of <place>) *world*) ;;; *ITEMS* in a list of all the items in the world. (global (list-of <item>) *items*) ;;; *CLOCK* is the number of clock ticks since the game began. (global <integer> *clock*) ;;; *QUIT* is a flag that is set by the player's quit command (global <boolean> *quit*) ;;; ;;; Functions to control playing a game and reseting a game. ;;; ;;; The function CLOCK plays a single turn by calling the tick and tock ;;; method of every item. (fglobal clock (function () (rebind! *clock* (1+ *clock*)) (output "*TICK!*") (for-each (function ((<item> item)) (if (memq item *items*) (tick item))) *items*) (output "*TOCK!*") (for-each (function ((<item> item)) (if (memq item *items*) (tock item))) *items*) *clock*)) ;;; The function START-GAME resets the game. It clobbers and rebuilds *CLOCK*, ;;; *WORLD*, and *ITEMS*. (fglobal start-game (function () (rebind! *world* '()) (rebind! *items* '()) (rebind! *clock* 0) (rebind! *quit* #f) (add-places) (connect-world) (add-items) *clock*)) (fglobal add-places (function () (instance <place> name '(college town)) (instance <building> name '(collegetown convenience store)) (instance <building> name '(olivers beer store)) (instance <building> name '(cafe decadence)) (instance <place> name '(college avenue)) (instance <place> name '(eddy street)) (instance <place> name '(buffalo street)) (instance <place> name '(state street)) (instance <place> name '(aurora street)) (instance <place> name '(central campus)) (instance <building> name '(gannett health center)) (instance <building> name '(campus store)) (instance <building> name '(day hall)) (instance <building> name '(barton hall)) (instance <place> name '(libes slope)) (instance <place> name '(west campus)) (instance <building> name '(johnnys hot truck)) ;; Well, not quite a building, (instance <place> name '(engineering quad)) ;; but you can't drive there. (instance <building> name '(upson basement)) (instance <building> name '(upson first)) (instance <building> name '(upson third)) (instance <building> name '(upson fourth)) (instance <building> name '(upson fifth)) (instance <building> name '(upson b7 lab)) (instance <office> name '(robotics lab)) (instance <office> name '(ramins office)) (instance <office> name '(dons office)) (instance <office> name '(justins office)) (instance <building> name '(cs lounge)))) ;;; ;;; The routine CONNECT-WORLD creates all the exits on the places in the world. ;;; (fglobal connect-world (function () (flet ((wire (function ((<symbol> to-a) (<description> a) (<symbol> to-b) (<description> b)) (let ((<place> match-a (find-place a)) (<place> match-b (find-place b))) (add-exit! (make-exit to-a match-a) match-b) (add-exit! (make-exit to-b match-b) match-a))))) ;; The Outside world. College Town, Central Campus, and Engineering ;; Quad (wire 'south '(college town) 'north '(central campus)) (wire 'southwest '(college town) 'northeast '(engineering quad)) (wire 'southeast '(engineering quad) 'northwest '(central campus)) ;; College town (wire 'out '(college town) 'in '(collegetown convenience store)) (wire 'out '(college town) 'in '(olivers beer store)) (wire 'out '(college town) 'in '(cafe decadence)) (wire 'north '(college town) 'south '(college avenue)) (wire 'east '(college town) 'west '(eddy street)) (wire 'north '(college avenue) 'south '(state street)) (wire 'east '(state street) 'west '(aurora street)) (wire 'southwest '(aurora street) 'northeast '(buffalo street)) (wire 'west '(buffalo street) 'east '(eddy street)) ;; Central campus (wire 'out '(central campus) 'in '(gannett health center)) (wire 'out '(central campus) 'in '(campus store)) (wire 'out '(central campus) 'in '(day hall)) (wire 'out '(central campus) 'in '(barton hall)) ;; West campus (wire 'southeast '(west campus) 'northwest '(johnnys hot truck)) (wire 'down '(west campus) 'up '(libes slope)) (wire 'down '(libes slope) 'up '(central campus)) ;; Upson (wire 'out '(engineering quad) 'in '(upson basement)) (wire 'out '(engineering quad) 'in '(upson first)) (wire 'down '(upson basement) 'up '(upson first)) (wire 'down '(upson first) 'up '(upson third)) (wire 'down '(upson third) 'up '(upson fourth)) (wire 'down '(upson fourth) 'up '(upson fifth)) (wire 'out '(upson third) 'in '(robotics lab)) (wire 'out '(upson fourth) 'in '(ramins office)) (wire 'out '(upson fifth) 'in '(dons office)) (wire 'out '(upson fifth) 'in '(justins office)) (wire 'out '(upson fifth) 'in '(cs lounge))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Generics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The object exchange protocol. ;;; (fglobal give? (generic)) (fglobal take? (generic)) (fglobal pickup (generic)) (fglobal drop (generic)) ;;; ;;; Moving around ;;; (fglobal go-to (generic)) ;;; ;;; Passage of time ;;; (fglobal tick (generic)) (fglobal tock (generic)) ;;; ;;; Hit points and combat ;;; (fglobal lose-hps! (generic)) (fglobal to-hit (generic)) (fglobal damage-mult (generic)) (fglobal retaliate-attack (generic)) ;;; ;;; Eating. ;;; (fglobal eat (generic)) ;;; ;;; Talking ;;; (fglobal say (generic)) (fglobal greet (generic)) (fglobal ack-greeting (generic)) ;;; ;;; Exits, et al (for multi classing car only.) ;;; (fglobal exits (generic)) (fglobal start-at (generic)) (fglobal xfer (generic)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Adventure objects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; <adventure-object> is the super class of both <place> and <item>. It ;;; handles the name and possessions of the instance. ;;; (class <adventure-object> ((<possessions> possessions '()) (<description> name '())) ()) ;;; ;;; Possessions ;;; (typedef <possessions> (list-headed-by <item>)) (fglobal add-possession! (function ((<adventure-object> object) (<item> possession)) (slot-rebind! object possessions (cons possession (slot-ref object possessions))))) (fglobal delete-possession! (function ((<adventure-object> object) (<item> possession)) (slot-rebind! object possessions (remove possession (slot-ref object possessions))))) (fglobal possessions (function ((<adventure-object> object)) (slot-ref object possessions))) ;;; ;;; All objects should have a description for a name. ;;; (fglobal name (function ((<adventure-object> object)) (slot-ref object name))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Output displays all of its arguments followed by a newline. ;;; (fglobal output (function (<list> args) (let ((<output-string-port> port (open-output-string))) (flet ((iter (function ((<list> args)) (cond ((not (null? args)) (display (car args) port) (iter (cdr args))))))) (iter args) (display (get-output-string port)) (newline))))) ;;; ;;; Filter ;;; (fglobal filter (function ((<function> predicate) (<list> list)) (cond ((null? list) '()) ((predicate (car list)) (cons (car list) (filter predicate (cdr list)))) (else (filter predicate (cdr list)))))) ;;; ;;; Descriptions ;;; (typedef <description> (list-of <symbol>)) ;;; ;;; Filter-descr takes two arguments. The first is a description and the ;;; second is a list of objects. This routine returns all of the objects ;;; in the list whose name matched the goal description, using DESCRS-MATCH? ;;; as the test. (fglobal filter-descr (function ((<description> goal) ((list-of <object>) objects) (<function> get-descr)) (filter (function ((<object> object)) (descrs-match? goal (get-descr object))) objects))) ;;; ;;; The predicate descr-match? takes two arguments, a goal description and ;;; a target description. This routine returns #t iff all of the symbols in ;;; the goal description appear in the target description. The target ;;; description is usually the name of an object. ;;; (fglobal descrs-match? (function ((<description> goal) (<description> target)) (or (null? goal) (and (memq (car goal) target) (descrs-match? (cdr goal) target))))) ;;; ;;; Find-place finds a place in the world from its description. ;;; (fglobal find-place (function ((<description> place)) (let (((list-of <place>) matches (filter-descr place *world* name))) (sanity (= (length matches) 1) (if (null? matches) "No place matches this description." "More than one place matches this description.") place (map name matches)) (car matches)))) ;;; ;;; Random-element returns a random element from a list. ;;; (fglobal random-element (function ((<list> list)) (list-ref list (random (length list))))) ;;; ;;; Play game plays a new game ;;; (fglobal play-game (generic (function () (start-game) (cont-game 20)) (function ((<integer> turns)) (start-game) (cont-game turns)))) (fglobal cont-game (generic (function () (cont-game (+ *clock* 20))) (function ((<integer> turns)) (rebind! *quit* #f) (flet ((next-turn (function ((<integer> to-go)) (cond ((and (> to-go 0) (not *quit*)) (clock) (next-turn (1- to-go))) (else #t))))) (next-turn turns) (for-each (generic (function ((<item> item)) '()) (function ((<animate> animate)) (let (((list-of <item>) possessions (possessions animate))) (cond ((null? possessions) (output (name animate) " is at " (name (possessor animate)) " and has nothing.")) (else (output (name animate) " is at " (name (possessor animate)) " and has... ") (for-each (function ((<item> item)) (output " " (name item))) possessions)))))) *items*)))))

place.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PLACE.BETTY ;;; The definition of all places. ;;; ;;; You CANNOT modify this file in any way. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The <place> class is the basis for all places. It has the state ;;; variables name, exits, and possessions. ;;; (class <place> ((<exits> exits '())) ;; The initialization function of a place should add the place ;; to the *WORLD*. (function ((<place> place)) (cnf) (rebind! *world* (cons place *world*)) (cnf)) ;;; A place is an adventure-object. <adventure-object>) ;;; ;;; Exits. ;;; (typedef <exit> (<symbol> <place>)) (typedef <exits> (list-headed-by <exit>)) (fglobal make-exit (function ((<symbol> direction) (<place> place )) (list direction place))) (fglobal exit-dir (function ((<exit> exit)) (car exit))) (fglobal exit-place (function ((<exit> exit)) (cadr exit))) (fglobal add-exit! (function ((<exit> exit) (<place> place)) (slot-rebind! place exits (cons exit (slot-ref place exits))))) (fglobal remove-exit! (function ((<exit> exit) (<place> place)) (slot-rebind! place exits (remove exit (slot-ref place exits))))) (add-functions exits (function ((<place> place)) (slot-ref place exits))) (fglobal random-place (function () (name (random-element *world*)))) ;;; ;;; Object exchange protocol. ;;; (add-functions give? (function ((<item> item-requested) (<place> decision-maker) (<adventure-object> requester)) (cond ((eq? (possessor item-requested) decision-maker) (xfer item-requested decision-maker requester) #t) (else (output (name item-requested) " isn't at " (name decision-maker) "!") #f)))) (add-functions take? (function ((<item> item-offered) (<place> decision-maker) (<adventure-object> offerer)) (cond ((eq? (possessor item-offered) offerer) (xfer item-offered offerer decision-maker) #t) (else #f)))) ;;; ;;; The <building> class is a subclass of <place>. Cars cannot go into buildings. ;;; (class <building> () () <place>) ;;; ;;; The <office> class is a subclass of <building>. Monsters cannot go into buildings. ;;; (class <office> () () <building>)

item.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ITEM.BETTY ;;; The definition of basic item classes ;;; ;;; You CANNOT modify this file in any way. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <item> class is the basis for all items. It keeps track of its ;;; possessor. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <item> ((<adventure-object> possessor)) () <adventure-object>) ;;; ;;; Start at place is used to put an item in an initial location. ;;; (fglobal start-at-place (function ((<item> item) (<description> place)) (sanity (not (memq item *items*)) "Item has already been put into the world." (name item)) (let ((<place> place (find-place place))) (start-at item place)))) (add-functions start-at (function ((<item> item) (<adventure-object> possessor)) (sanity (not (memq item *items*)) "Item has already been put into the world." (name item)) (add-possession! possessor item) (slot-rebind! item possessor possessor) (rebind! *items* (cons item *items*)) item)) ;;; ;;; The possessor of an item ;;; (fglobal possessor (function ((<item> item)) (slot-ref item possessor))) ;;; ;;; The place that the item is in, directly or indirectly. ;;; Note: something that is a place and an item is not its own place. ;;; (fglobal place-of (function ((<item> item)) (place-of-helper (possessor item)))) (fglobal place-of-helper (generic (function ((<place> place)) place) (function ((<item> item)) (place-of-helper (possessor item))))) ;;; ;;; Transferring objects from one adventure-object to another. ;;; (add-functions xfer (function ((<item> item) (<adventure-object> from) (<adventure-object> to)) (cond ((eq? (possessor item) from) (delete-possession! from item) (add-possession! to item) (slot-rebind! item possessor to)) ((instance-of? <place> from) (output (name item) " isn't at " (name from) "!")) (else (output (name from) " doesn't have " (name item) "!"))))) ;;; ;;; Destroying an item means we must destroy all of its possessions as well. ;;; (fglobal destroy (function ((<item> item)) (for-each destroy (possessions item)) (delete-possession! (slot-ref item possessor) item) (rebind! *items* (remove item *items*)) (output "*Destroying " (name item) "*"))) ;;; ;;; Go-to lets an item move to a new place, iff it is at a place. ;;; (Note that animates are things to!) ;;; (add-functions go-to (function ((<item> item) (<place> new-place)) (cond ((not (connected-to (place-of item) new-place)) #f) ((give? item (possessor item) new-place) (output (name item) " moves to " (name new-place) ".") #t) (else #f)))) (fglobal connected-to (generic (function ((<place> src) (<place> dest)) (member dest (map (function ((<exit> e)) (exit-place e)) (exits src)))))) ;;; ;;; Tick and tock do nothing for a basic item. ;;; (add-functions tick (function ((<item> item)) '())) (add-functions tock (function ((<item> item)) '())) ;;; ;;; The object exchange protocol. Basic items will not give, take, or trade any items. ;;; (add-functions give? (function ( (<item> item-requested) (<item> item) (<adventure-object> requester)) #f)) (add-functions take? (function ((<item> item-offered) (<item> item) (<adventure-object> offerer)) #f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <lethal> class is a subclass of <item>. This class is used to ;;; model lethal objects, like assault rifles. ;;; ;;; The generics min-damage and max-damage are used to model their damage. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <lethal> ((<integer> min-damage) (<integer> max-damage)) () <item>) (fglobal min-damage (function ((<lethal> gun)) (slot-ref gun min-damage))) (fglobal max-damage (function ((<lethal> gun)) (slot-ref gun max-damage))) ;;; ;;; Dog's teeth ;;; (class <teeth> () (function ((<teeth> teeth)) (cnf) (slot-rebind! teeth name '(teeth)) (slot-rebind! teeth min-damage 1) (slot-rebind! teeth max-damage 4)) <lethal>) ;;; ;;; Guns ;;; (class <gun> () () <lethal>) ;;; ;;; Assault-rifles ;;; (class <assault-rifle> () (function ((<assault-rifle> gun)) (cnf) (slot-rebind! gun name '(assault rifle)) (slot-rebind! gun min-damage 1) (slot-rebind! gun max-damage 10)) <gun>) ;;; ;;; Police-specials ;;; (class <police-special> () (function ((<police-special> gun)) (cnf) (slot-rebind! gun name '(police special)) (slot-rebind! gun min-damage 11) (slot-rebind! gun max-damage 20)) <gun>) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <armor> class is a subclass of <item>. This class is used to ;;; model armor which absorbs damage. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <armor> ((<integer> hps 10)) () <item>) (add-functions lose-hps! (function ((<armor> armor) (<integer> damage)) (let ((<integer> new-hps (- (slot-ref armor hps) damage))) (slot-rebind! armor hps new-hps) (cond ((<= new-hps 0) (output (name armor) " can't take anymore damage!") (destroy armor)) (else (output (name armor) " absorbs the damage!")))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Attack-with handles the general attacking paradym. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (fglobal attack-with (function ((<lethal> weapon) (<animate> victim)) (let ((<animate> attacker (possessor weapon))) (output (name attacker) " attacks " (name victim) "...") (let ((<boolean> hit? (<= (random 100) (to-hit attacker)))) (if hit? (let ((<integer> damage (* (damage-mult attacker) (+ (min-damage weapon) (random (- (max-damage weapon) (min-damage weapon)))))) ((list-of <armor>) armors (filter (function ((<item> item)) (instance-of? <armor> item)) (possessions victim)))) (cond ((null? armors) (output (name attacker) " does " damage " point(s) of damage to " (name victim) ".") (lose-hps! victim damage)) (else (let ((<armor> armor (random-element armors))) (output (name attacker) " hits " (name victim) " but the " (name armor) " absorbs the blow.") (lose-hps! armor damage))))) (output (name attacker) " misses " (name victim))) ;;; If the victim is not dead, let him retaliate. (if (not (dead? victim)) (retaliate-attack victim attacker)) ;;; Return #t iff the attacker actually hit the victim. hit?)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <edible> class is a subclass of <item>. This class is used to ;;; model all items which are fit for human consumption. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <edible> ((<integer> freshness 5)) () <item>) (add-functions tick (function ((<edible> food)) (slot-rebind! food freshness (1- (slot-ref food freshness))))) (fglobal still-edible? (function ((<edible> food)) (positive? (slot-ref food freshness)))) (add-functions eat (function ((<edible> food ) (<animate> eater)) (cond ((not (eq? (possessor food) eater)) (output (name eater) " tried to eat the " (name food) " but doesn't have it!") #f) ((still-edible? food) (say eater "Mmmm... That " (name food) " really hit the spot!") (destroy food) #t) (else (say eater "Pppffgghh!! That " (name food) " tasted funny!") (lose-hps! eater 1) (destroy food) #t)))) ;;; ;;; The <body> class is a subclass of the <edible> class (How VERY rude!). ;;; (class <body> () (function ((<body> body)) (cnf) (slot-rebind! body freshness 6)) <edible>) ;;; ;;; The <beer> class is a subclass of <edible>. ;;; (class <beer> () (function ((<beer> beer)) (cnf) (slot-rebind! beer freshness 10) (slot-rebind! beer name (random-element '((pitcher watneys red) (six-pack bud) (case labatts blue) (fosters oilcan) (pitcher ro ro))))) <edible>) ;;; ;;; The <pizza> class is a subclass of the <edible> class. ;;; (class <pizza> () (function ((<pizza> pizza)) (cnf) (slot-rebind! pizza freshness 15) (slot-rebind! pizza name (random-element '((poor mans pizza) (ra ra) (meat ball cheese) (wtf) (shaggy link death liquid on a half))))) <edible>) ;;; ** Modification: Donald: 3/14/94 ;;; ;;; The <money> class is a subclass of <item> class. ;;; Note: money has no value, everything in the game cost one money unit. ;;; (class <money> () (function ((<money> money)) (cnf) (slot-rebind! money name '(some money))) <item>)

animate.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ANIMATE.BETTY ;;; The definition of animate item classes ;;; ;;; You CANNOT modify this file in any way. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <animate> class is a subclass of <item>. It handles all living ;;; beings. Animates keep track of ;;; ;;; hps - The animate objects state of health. The hight the hps, the ;;; better off it is. 0 hps signifies death. ;;; ;;; max-hps - The maximum number of hit points the object can have. ;;; ;;; hps-delta - The amount of hit points an object regenerates in one turn ;;; (The "healing" process.) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <animate> ((<integer> max-hps 20) (<integer> hps 20) (<integer> hps-delta 1 )) () <item>) (fglobal gain-hps! (function ((<animate> animate) (<integer> delta)) (slot-rebind! animate hps (min (slot-ref animate max-hps) (+ (slot-ref animate hps) delta))))) (fglobal regen-hps! (function ((<animate> animate)) (slot-rebind! animate hps (min (slot-ref animate max-hps) (+ (slot-ref animate hps-delta) (slot-ref animate hps)))) #t)) (add-functions lose-hps! (function ((<animate> animate) (<integer> delta)) (slot-rebind! animate hps (- (slot-ref animate hps) delta)) (if (dead? animate) (die animate)))) ;;; ;;; An animate is dead is it has 0 (or fewer) hit points. ;;; (fglobal dead? (function ((<animate> animate)) (<= (slot-ref animate hps) 0))) ;;; ;;; Attacking paramaters. ;;; ;;; To-hit is the chance in 100 of this animate hitting. ;;; Damage-mult is the damage multiplying this animate has if it hits. ;;; (add-functions to-hit (function ((<animate> animate)) 50)) (add-functions damage-mult (function ((<animate> animate)) 1)) ;;; ;;; Moving. ;;; ;;; Move allows a creature to move according to its own policy. The default ;;; is to move to a random neighbor location, pick up anything that is just lying ;;; around, and to greet all animate objects at the new location. ;;; (fglobal move (function ((<animate> animate)) (let ((<adventure-object> old-location (possessor animate))) (let (((list-of <exit>) exits (exits old-location))) (if (null? exits) (say animate "Hey!!! I'm trapped!!! Let me out.") (let ((<place> new-location (exit-place (random-element exits)))) ;;; Move (cond ((go-to animate new-location) ;; If we move successfully. ;; Pickup items lying around (except animates!) (for-each (function ((<item> item)) (if (and (not (instance-of? <animate> item)) (want-item? animate item)) (pickup item animate))) (possessions new-location)) ;; Greet all animates (except yourself!) (for-each (function ((<item> item)) (if (and (instance-of? <animate> item) (not (eq? item animate))) (greet item animate))) (possessions new-location))) (else ;; We couldn't move (say animate "Guess I won't move this turn."))))))) #t)) ;;; ;;; Decides whether we want to pick up an item that's lying around. ;;; By default, say yes 1/4 of the time. ;;; (fglobal want-item? (generic (function ((<animate> animate) (<item> item)) (< (random 1000) 250)))) ;;; ;;; Policy for retailating to attacks -- if we have a weapon, fight back, otherwise flee. ;;; (add-functions retaliate-attack (function ((<animate> animate) (<animate> attacker)) (let (((list-of <lethal>) lethals (filter (function ((<item> item)) (instance-of? <lethal> item)) (possessions animate)))) (cond ((null? lethals) (say animate "I have no weapons! Run away!!") (move animate)) (else (say animate "That wasn't a very nice thing to do.") (attack-with (random-element lethals) attacker)))))) ;;; ;;; The die method causes an animate object to die. This consists of, ;;; ;;; o Changing the owner of agent's possesors to the agent's location. In ;;; other words, the agent drops everything when it dies. ;;; o Changing the agent from an animate object to an edible object (How ;;; rude!). ;;; (fglobal die (function ((<animate> animate)) (say animate "Aagggghhh!!...") (output (name animate) " dies.") ;;; Drop everything. (for-each (function ((<item> possession)) (drop possession animate)) (possessions animate)) ;;; Add the animate's body to the current location. (start-at (instance <body> name (cons 'dead (name animate))) (possessor animate)) ;;; Destroy the animate. (destroy animate))) ;;; ;;; Greetings. ;;; ;;; Greet causes an animate to greet a neighbor, and then allow them to acknowledge ;;; the greeting. ;;; (add-functions greet (function ((<animate> neighbor) (<animate> greeter)) (say greeter "Hello, " (name neighbor) "!") (ack-greeting neighbor greeter))) (add-functions ack-greeting (function ((<animate> neighbor) (<animate> greeter)) (say neighbor "Hello, " (name greeter) "!"))) ;;; ;;; Say just prints dialog. ;;; (add-functions say (function ((<animate> animate) . (<object> text)) (apply output (append (list (name animate) " says, \"") text (list "\""))))) ;;; ;;; Animates regenerate on ticks and move on tocks. ;;; (add-functions tick (function ((<animate> animate)) (regen-hps! animate))) (add-functions tock (function ((<animate> animate)) (move animate))) ;;; ;;; The object exchange protocol. Animate objects are basically ;;; friendly, so they give and take objects freely. Shades of ;;; POOR-TRUSTING-FOOL, no? ;;; (add-functions give? (function ((<item> item-requested) (<animate> decision-maker) (<adventure-object> requester)) (cond ((eq? (possessor item-requested) decision-maker) (say decision-maker "Sure, here you go.") (xfer item-requested decision-maker requester) #t) (else (say decision-maker "Sorry, I don't have a " (name item-requested) ".") #f)))) (add-functions take? (function ((<item> item-offered) (<animate> decision-maker) (<adventure-object> offerer)) (cond ((eq? (possessor item-offered) offerer) (say decision-maker "I'll take it!") (xfer item-offered offerer decision-maker) #t) (else (say decision-maker "You don't have a " (name item-offered) "!") #f)))) ;;; ;;; Pickup and drop are wrappers around the object exchange protocol ;;; (add-functions pickup (function ((<item> item) (<animate> animate)) (if (give? item (possessor animate) animate) (output (name animate) " picks up " (name item) ".")))) (add-functions drop (function ((<item> item) (<animate> animate)) (if (take? item (possessor animate) animate) (output (name animate) " drops " (name item) ".")))) ;;; ;;; However, animates won't stand being passed around, if they can help it. ;;; (add-functions pickup (function ((<animate> annoyed) (<animate> animate)) (say annoyed "Get your hands off me, " (name animate) ", you pervert!") (move annoyed) (cnf))) (add-functions drop (function ((<animate> annoyed) (<animate> animate)) (cnf) (say annoyed "I'm free at last!") (move annoyed))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <student> class is a subclass of <animate>. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <student> () () <animate>) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <dog> class is a subclass of <animate>. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <dog> ((<teeth> teeth)) (function ((<dog> dog)) (cnf) (let ((<teeth> teeth (instance <teeth>))) (start-at teeth dog) (slot-rebind! dog teeth teeth))) <animate>) ;;; ;;; Sniff? causes a dog to sniff an object, and returns #t of #f. ;;; (fglobal sniff? (generic (function ((<dog> dog) (<item> item) (<function> obtain)) (output (name dog) " sniffs " (name item) ".") #f) (function ((<dog> dog) (<edible> food) (<function> obtain)) (output (name dog) " sniffs the " (name food) ".") (cond ((and (obtain) (not (dead? dog))) (output (name dog) " wolfs down " (name food) ".") (eat food dog) #t) (else #f))))) ;;; ;;; Dogs can't talk. ;;; (add-functions say (function ((<dog> dog) . (<object> text)) (output (name dog) " says, \"woof!\""))) ;;; ;;; Dogs get stronger everytime they eat ;;; (add-functions eat (function ((<edible> food) (<dog> dog)) (cond ((cnf) (slot-rebind! dog max-hps (+ (slot-ref dog max-hps) (if (still-edible? food) 5 1))) #t) (else #f)))) ;;; ;;; Dogs almost never miss. ;;; (add-functions to-hit (function ((<dog> dog)) 99)) ;;; ;;; Once in a while they get a really good hit, but usually, their damage multiplier ;;; is just 1. ;;; (add-functions damage-mult (function ((<dog> dog)) (if (= (random 2) 0) (1+ (random 8)) 1))) ;;; ;;; Dogs only pickup food ;;; (add-functions pickup (function ((<item> item) (<dog> dog)) (sniff? dog item cnf))) ;;; ;;; When they greet animates, they sniff a random item on them for food. ;;; If they have no items, he will bark. ;;; (add-functions greet (function ((<animate> neighbor) (<dog> dog)) (let (((list-of <item>) items (possessions neighbor))) (if (not (null? items)) (let ((<item> item (random-element items))) (sniff? dog item (obtain-item neighbor item dog))) (begin (say dog) (ack-greeting neighbor dog)))))) (fglobal obtain-item (function ((<animate> neighbor) (<item> item) (<dog> dog)) (function () (cond ((give? item neighbor dog) #t) ((not (eq? (possessor neighbor) (possessor dog))) (output (name dog) " chases " (name neighbor) " to " (name (possessor neighbor)) ".") (xfer dog (possessor dog) (possessor neighbor)) (attack-with (slot-ref dog teeth) neighbor) (and (dead? neighbor) (pickup item dog))) ((= (random 3) 1) (attack-with (slot-ref dog teeth) neighbor) (and (dead? neighbor) (pickup item dog))) (else (output (name dog) " growls at " (name neighbor) ".") #f))))) (add-functions ack-greeting (function ((<dog> dog) (<animate> greeter)) (let (((list-of <item>) items (possessions greeter))) (if (not (null? items)) (let ((<item> item (random-element items))) (sniff? dog item (obtain-item-2 dog item greeter))) (say dog))))) (fglobal obtain-item-2 (function ((<dog> dog) (<item> item) (<animate> greeter)) (function () (cond ((give? item greeter dog) #t) ((= (random 3) 1) (attack-with (slot-ref dog teeth) greeter) (and (dead? greeter) (pickup item dog))) (else (output (name dog) " growls at " (name greeter) ".") #f))))) ;;; ;;; ;;; Dogs can't carry objects. ;;; (add-functions give? (function ((<item> item-requested) (<dog> decision-maker) (<adventure-object> requester)) (output (name decision-maker) " wags its tail.") #f)) ;;; ;;; Dogs will only sniff? everything they might take food, which they eat immediately. ;;; (add-functions take? (function ((<item> item-offered) (<dog> decision-maker) (<adventure-object> requester)) (sniff? decision-maker item-offered cnf))) ;;; ;;; Dogs won't drop their teeth (they're attached!) ;;; (add-functions drop (function ((<teeth> teeth) (<dog> dog)) (if (eq? teeth (slot-ref dog teeth)) #f (cnf)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <proprietor> class is a subclass of <animate>. Proprietors don't ;;; move and the try to sell something, as defined by the slot ;;; constuctor. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <proprietor> ((<function> constructor)) () <animate>) (fglobal make-new-item (function ((<proprietor> proprietor)) (let ((<item> item ((slot-ref proprietor constructor)))) (start-at item proprietor) (output (name proprietor) " makes a new " (name item) ".")))) ;;; Proprietors don't move. But, if they are selling food, they need ;;; to make sure every turn that the food is still edible. If it's not, ;;; throw out the old food. (add-functions tick (function ((<proprietor> proprietor)) (for-each (function ((<item> item)) (cond ((and (instance-of? <edible> item) (not (still-edible? item))) (say proprietor "Ack! " (name item) " went bad. Better make some more.") (destroy item)))) (possessions proprietor)))) ;;; On the tock phase, a proprietor makes a new item, if they don't already have ;;; something to sell. (add-functions tock (function ((<proprietor> proprietor)) (if (null? (possessions proprietor)) (make-new-item proprietor)))) ;;; When proprietors acknowledge greetings, they will try to sell any ;;; items they might have ;;; ** Modification: Donald: 3/14/94 ;;; Now proprietor check for money, and take one automatically. ;;; Only after it takes the money, it will give you the object. (add-functions ack-greeting (function ((<proprietor> proprietor) (<animate> greeter)) ;; Respond to the greeting in the usual manner. (cnf) ;; And now try to sell something. (cond ((null? (possessions proprietor)) (say proprietor "Oh my, I seem to be out of goods, can you come back later?")) ((has-money? greeter) (let ((<item> for-sale (random-element (possessions proprietor)))) (say proprietor "Can I interest you in " (name for-sale) "?") (cond ((take? for-sale greeter proprietor) (say proprietor "Thanks for doing business at the " (name (possessor proprietor)) ".")) (else (say proprietor "If you won't pay, I can't sell you this.") )))) (else (say proprietor "You need money to buy something..."))))) ;;; ** Modification: Donald: 3/11/94 ;;; ;;; has-money? check if the object has any money. ;;; (fglobal has-money? (function ((<adventure-object> obj)) (not (eq? (get-money obj) #f)))) ;;; ** Modification: Donald: 3/11/94 ;;; ;;; get-money returns the first <money> object in the character list. ;;; (fglobal get-money (function ((<adventure-object> obj)) (let ((<list> stuff (filter is-money? (possessions obj)))) (if (null? stuff) #f (car stuff))))) (fglobal is-money? (generic (function ((<adventure-object> o)) #f) (function ((<money> l)) #t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <dean> class is a subclass of the <monster> class. Deans run around ;;; looking for students with beer. They destroy any beer on a student's ;;; person. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <dean> () () <monster>) ;;; When dean's greet students, they check them for beer. ;;; (add-functions greet (function ((<student> student) (<dean> dean)) (let (((list-of <beer>) beers (filter (function ((<item> item)) (instance-of? <beer> item)) (possessions student)))) (cond ((not (null? beers)) (say dean "You have BEER! Shame on you, " (name student) "! I'll have to " "destroy your beer and call your parents!") (for-each destroy beers)))))) ;; Deans are a bit more polite than other monsters. Well, they ;; acknowledge students's greetings anyway, but they still don't give ;; prof's or TA's the time of day. (add-functions ack-greeting (function ((<dean> neighbor) (<student> greeter)) (say neighbor "Well, hello there!"))) (add-functions ack-greeting (function ((<dean> neighbor) (<animate> greeter)) (say neighbor "..."))) ;;; The MONSTER class is a subclass of the ANIMATE class. It is used for ;;; implementing cops and deans (of course). (class <monster> () (function ((<monster> monster)) (cnf) (slot-rebind! monster max-hps 40) (slot-rebind! monster hps 40) (slot-rebind! monster hps-delta 2)) <animate>) ;; Attacking parameters (add-functions to-hit (function ((<monster> monster)) 75)) (add-functions damage-mult (function ((<monster> monster)) 2)) ;; Monsters will wander anywhere accept into offices. (add-functions go-to (function ((<monster> monster) (<office> new-place)) (say monster "Ack! I can't go in there. It's an office!") #f)) ;; Monsters move during the tick phase of the turn, and regenerate during ;; the tock. (add-functions tick (function ((<monster> monster)) (move monster))) (add-functions tock (function ((<monster> monster)) (regen-hps! monster))) ;; Change the 'GREET and 'ACK-GREETING messages too, because ;; monsters aren't friendly. (add-functions greet (function ((<animate> neighbor) (<monster> greeter)) #f)) (add-functions ack-greeting (function ((<monster> neighbor) (<animate> greeter)) (say neighbor (random-element '("Hello, yourself!" "Get lost!" "What's it to you!"))))) ;; The object exchange protocol. Monsters only exchange with other ;; monsters. If the requester is a monster, then do the exchange. (add-functions give? (function ((<item> item-requested) (<monster> decision-maker) (<adventure-object> requester)) (say decision-maker "I don't want to give it to you.") #f) (function ((<item> item-requested) (<monster> decision-maker) (<monster> requester)) (cond ((eq? (possessor item-requested) decision-maker) (say decision-maker "Sure, here you go.") (xfer item-requested decision-maker requester) #t) (else (say decision-maker "Sorry, I don't have a " (name item-requested) ".") #f)))) (add-functions take? (function ((<item> item-offered) (<monster> decision-maker) (<adventure-object> requester)) (say decision-maker "I don't want to take it from you.") #f) (function ((<item> item-offered) (<monster> decision-maker) (<monster> offerer)) (cond ((eq? (possessor item-offered) offerer) (say decision-maker "I'll take it!") (xfer item-offered offerer decision-maker) #t) (else (say decision-maker "You don't have a " (name item-offered) "!") #f)))) ;;; ;;; The COP class is a subclass of the MONSTER class. Cops run around ;;; looking for students carrying lethal weapons. If they find a student ;;; with a weapon, the student is in serious trouble. (class <cop> ((<police-special> gun)) (function ((<cop> cop)) (cnf) (let ((<police-special> gun (instance <police-special>))) (start-at gun cop) (slot-rebind! cop gun gun)) (start-at (instance <edible> name '(donut)) cop)) <monster>) (add-functions greet (function ((<student> student) (<cop> cop)) (let (((list-of <lethal>) weapons (filter is-lethal? (possessions student)))) (cond ((not (null? weapons)) (say cop "You have a lethal WEAPON, " (name student) "! Eat hot lead, sucker!") (attack-with (slot-ref cop gun) student)) (else (cnf)))))) (fglobal is-lethal? (generic (function ((<adventure-object> o)) #f) (function ((<lethal> l)) #t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; CS212 staff ;;; We are invincible ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <staff> () () <animate>) ;; Staff don't lose hit points (add-functions lose-hps! (function ((<staff> staff) (<integer> delta)) #f)) ;; Staff are kind people, and doesn't retaliate (add-functions retaliate-attack (function ((<staff> staff) (<animate> attacker)) (say staff "Please run along and point that peashooter elsewhere.") #f)) ;;; And then, there is Prof. Zabih (class <prof> () () <staff>) (add-functions retaliate-attack (function ((<prof> prof) (<animaate> attacker)) (say prof "How DARE you!!!!!! Take this prelim you worthless scum!!") (die attacker) ))

interactive.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; INTERACTIVE.BETTY ;;; The definition of interactive item classes ;;; ;;; You CANNOT modify this file in any way. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The <interactive> class is a subclass of <student>. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (class <interactive> () () <student>) (add-functions tock (function ((<interactive> self)) (let ((<adventure-object> possessor (possessor self))) (output) (output (name self) ":") (look-around self) (interactive-command self)))) ;;; ;;; Object exchange protocol. ;;; (add-functions give? (function ((<item> item-requested) (<interactive> decision-maker) (<adventure-object> requester)) (output (name decision-maker) ", " (name requester) " asks you for your " (name item-requested) ".") (output "Give it up?") (let iter ((<command> command (get-command decision-maker))) (case (car command) ((y yes) (cnf)) ((n no) #f) (else (output "Please answer yes or no.") (iter (get-command decision-maker))))))) (add-functions take? (function ((<item> item-requested) (<interactive> decision-maker) (<adventure-object> requester)) (output (name decision-maker) ", " (name requester) " offers you " (name item-requested) ".") (output "Accept it?") (let iter ((<command> command (get-command decision-maker))) (case (car command) ((y yes) (cnf)) ((n no) #f) (else (output "Please answer yes or no.") (iter (get-command decision-maker))))))) ;;; ;;; Retailiating to an attack. ;;; (add-functions retaliate-attack (function ((<interactive> self) (<animate> attacker)) (interactive-command self))) ;;; ;;; Acknowledging greetings. ;;; (add-functions ack-greeting (function ((<interactive> self) (<animate> greeter)) (output (name self) ", acknowledge the greeter?") (let iter ((<command> command (get-command self))) (case (car command) ((y yes) (say self "Hello, " (name greeter) "!")) ((n no) '()) (else (output "Please answer yes or no.") (iter (get-command self))))))) ;;; ;;; List everything at a location. ;;; (fglobal look-around (function ((<interactive> self)) (let* ((<adventure-object> location (possessor self)) ((list-of <exit>) exits (exits location)) ((list-of <item>) things (remove self (possessions location)))) (cond ((instance-of? <place> location) (output "You are at " (name location)) (if (null? things) (output "There is nothing here.") (for-each (function ((<item> item)) (output "You see " (name item) ".")) things)) (if (null? exits) (output "There appears to be no way out.") (for-each (function ((<exit> exit)) (output "You can go " (exit-dir exit) " to " (name (exit-place exit)) ".")) exits))) (else (output (name location) " is holding you!")))))) ;;; ;;; Processing the command. ;;; (fglobal interactive-command (generic (function ((<interactive> self)) (interactive-command self (function ((<command> command)) (list #f '())) '())) (function ((<interactive> self) (<function> context) (<object> default-ret-val)) (cond ((dead? self) (output (name self) " is dead!") default-ret-val) (else (let* ((<command> command (get-command self)) (<object> action (find-action (command-verb command)))) (if action (cond ((do-action self action command) (output) default-ret-val) (else (interactive-command self (function ((<command> command)) (list #f '())) default-ret-val))) (apply (function ((<boolean> accept?) (<object> ret-val)) (cond (accept? ret-val) (else (output (random-element '("Huh?" "I don't know what you mean." "I couldn't parse that command." "I didn't understand that!"))) (interactive-command self context default-ret-val)))) (context command))))))))) ;;; ;;; Command data abstraction ;;; (typedef <command> (<symbol> . (list-of <symbol>))) (fglobal command-verb (function ((<command> command)) (car command))) (fglobal command-noun (function ((<command> command)) (parse-noun (cdr command)))) (fglobal command-preps (function ((<command> command)) (filter (function ((<symbol> symbol)) (memq symbol *preps*)) command))) (fglobal command-prep (function ((<command> command) (<symbol> prep)) (find-prep-phrase (cdr command) prep))) (fglobal find-prep-phrase (function ((<description> command) (<symbol> prep)) (cond ((null? command) (cons prep '())) ((eq? (car command) prep) (cons prep (parse-noun (cdr command)))) (else (find-prep-phrase (cdr command) prep))))) (fglobal parse-noun (function ((<description> command)) (cond ((null? command) '()) ((memq (car command) *preps*) '()) (else (cons (car command) (parse-noun (cdr command))))))) (fglobal get-command (flet ((check-command (generic (function ((<interactive> self) (<command> command)) command) (function ((<interactive> self) (<symbol> command)) (list command)) (function ((<interactive> self) (<object> command)) (output "Get a life! Get a real command.") (output "I only understand symbols and lists of symbols.") (get-command self))))) (function ((<interactive> self)) (display (name self)) (display " ==> ") (let iter ((<object> command (read))) (newline) (check-command self command))))) ;;; ;;; Do action ;;; (fglobal do-action (function ((<interactive> self) (<action> action) (<command> command)) (let ((<object> slots (get-slots (action-slots action) command self))) (cond ((boolean? slots) slots) (else (apply (action-perform action) (cons self slots))))))) ;;; ;;; Actions ;;; (structure <action> (((list-of <symbol>) verbs) ((list-of <slot>) slots) (<function> perform))) (global (list-of <symbol>) *preps* ) (global (list-of <action>) *actions*) (fglobal reset-actions! (function () (rebind! *preps* '()) (rebind! *actions* '()) '())) (fglobal add-action! (function ((<action> action)) (for-each (function ((<slot> slot)) (for-each (function ((<object> prep)) (if (and (not (null? prep)) (not (memq prep *preps*))) (rebind! *preps* (cons prep *preps*)))) (slot-preps-ok slot))) (action-slots action)) (rebind! *actions* (cons action *actions*)) (action-verbs action))) (fglobal find-action (function ((<symbol> verb)) (let iter (((list-headed-by <action>) actions *actions*)) (cond ((null? actions) #f) ((memq verb (action-verbs (car actions))) (car actions)) (else (iter (cdr actions))))))) ;;; ;;; slots ;;; (structure <slot> (((<object> . (list-of <object>)) preps-ok) (<function> get-inits) (<function> get-descr) (<boolean> optional?) (<boolean> multiple?) (<string> ask-for-value) (<string> nothing-possible) (<string> nothing-matches))) (fglobal slot-main-prep (function ((<slot> slot)) (let ((<object> prep (car (slot-preps-ok slot)))) (if (null? prep) "" (string-append (symbol->string prep) " "))))) (fglobal get-slots (function (((list-of <slot>) slots) (<command> command) (<interactive> self)) (let ((<description> direct-object (command-noun command)) ((list-of (<symbol> . <description>)) preps (map (function ((<symbol> prep)) (command-prep command prep)) (command-preps command)))) (apply second-pass (first-pass self slots (if (null? direct-object) preps (cons (cons '() direct-object) preps))))))) (fglobal first-pass (function ((<interactive> self) ((list-of <slot>) slots) ((list-of (<object> . <description>)) preps)) (let iter (((list-headed-by <slot>) slots slots) ((list-headed-by (<object> . <description>)) preps preps) ((list-headed-by <slot>) done '()) ((list-headed-by <boolean>) done-assigned? '()) ((list-headed-by <boolean>) done-multiple? '()) ((list-headed-by (list-of <object>)) done-values '())) (if (null? slots) (list self (map car preps) done done-assigned? done-multiple? done-values) (apply (function ((<boolean> assigned?) (<boolean> multiple?) ((list-of <object>) values) (<object> prep-used)) (iter (cdr slots) (if assigned? (filter (function (((<object> . (list-of <symbol>)) prep)) (not (eq? (car prep) prep-used))) preps) preps) (cons (car slots) done) (cons assigned? done-assigned?) (cons multiple? done-multiple?) (cons values done-values))) (find-values preps (slot-preps-ok (car slots)) (slot-get-descr (car slots)) ((slot-get-inits (car slots)) self))))))) (fglobal find-values (function (((list-headed-by (<object> . <description>)) preps) ((list-of <object>) preps-ok) (<function> get-descr) ((list-of <object>) inits)) (cond ((null? preps) (list #f #f inits #f)) ((memq (caar preps) preps-ok) (apply (function ((<description> noun) (<symbol> modifier)) (let (((list-of <object>) values (filter-descr noun inits get-descr))) (if (null? values) (find-values (cdr preps) preps-ok get-descr inits) (list #t (eq? modifier 'all) values (caar preps))))) (let ((<description> noun (cdar preps))) (cond ((null? noun) (list '() 'a)) ((memq (car noun) '(a an all the)) (list (cdr noun) (car noun))) (else (list noun 'a)))))) (else (find-values (cdr preps) preps-ok get-descr inits))))) (fglobal second-pass (function ((<interactive> self) ((list-of <object>) unused-preps) ((list-of <slot>) slots) ((list-of <boolean>) assigned?) ((list-of <boolean>) multiple?) ((list-of (list-of <object>)) values)) (let iter (((list-headed-by <slot>) slots slots) ((list-headed-by <boolean>) assigned? assigned?) ((list-headed-by <boolean>) multiple? multiple?) ((list-headed-by (list-of <object>)) values values) ((list-headed-by <slot>) done-slots '()) ((list-headed-by <boolean>) done-assigned? '()) ((list-headed-by <boolean>) done-multiple? '()) ((list-headed-by (list-of <object>)) done-values '())) (cond ((null? slots) (cond ((null? unused-preps) (third-pass self done-slots done-assigned? done-multiple? done-values)) (else (output "Get a life! That sentence was too complicated!") (output unused-preps) #f))) ((and (car multiple?) (car assigned?) (not (slot-multiple? (car slots)))) (output "Multiple objects not allowed in this context.") #f) ((and (null? (car values)) (not (slot-optional? (car slots)))) (output (slot-nothing-possible (car slots))) #f) ((and (not (car assigned?)) (not (slot-optional? (car slots))) (some? (function ((<object> prep)) (memq prep unused-preps)) (slot-preps-ok (car slots)))) (output (slot-nothing-matches (car slots))) #f) (else (iter (cdr slots) (cdr assigned?) (cdr multiple?) (cdr values) (cons (car slots) done-slots) (cons (car assigned?) done-assigned?) (cons (car multiple?) done-multiple?) (cons (car values) done-values))))))) (fglobal third-pass (function ((<interactive> self) ((list-of <slot>) slots) ((list-of <boolean>) assigned?) ((list-of <boolean>) multiple?) ((list-of (list-of <object>)) values)) (let iter (((list-headed-by <slot>) slots slots) ((list-headed-by <boolean>) assigned? assigned?) ((list-headed-by <boolean>) multiple? multiple?) ((list-headed-by (list-of <object>)) values values) ((list-headed-by <object>) done-values '())) (if (null? slots) (reverse done-values) (let ((<object> next-value (let* ((<slot> slot (car slots)) (<boolean> slot-multiple? (slot-multiple? slot)) (<function> get-descr (slot-get-descr slot)) (<string> slot-prep (slot-main-prep slot))) (let iter ((<boolean> assigned? (car assigned?)) (<boolean> multiple? (car multiple?)) ((list-of <object>) values (car values))) (let* (((list-of <object>) values (cond ((not slot-multiple?) (remove-duplicates values get-descr)) ((or multiple? (not assigned?)) values) (else (remove-duplicates values get-descr)))) (<boolean> single-value? (null? (cdr values)))) (cond ((not assigned?) (cond ((slot-optional? slot) '()) (single-value? (output "[" slot-prep (get-descr (car values)) "]") (if slot-multiple? values (car values))) (else (output (slot-ask-for-value slot)) (interactive-command self (function ((<description> descr)) (apply (function ((<symbol> modifier) (<description> descr)) (let (((list-of <object>) new-values (filter-descr descr values get-descr)) (<boolean> multiple? (eq? modifier 'all))) (cond ((null? new-values) (list #f '())) ((and multiple? (not slot-multiple?)) (output "Multiple objects not " "allowed in this context.") (list #t (iter #f #f values))) (else (list #t (iter #t multiple? new-values)))))) (cond ((null? descr) (list 'a '())) ((memq (car descr) '(a an all the)) (list (car descr) (cdr descr))) (else (list 'a descr))))) #t)))) (multiple? values) (single-value? (if slot-multiple? values (car values))) (else (apply output (append (list "Were you refering to " (get-descr (car values))) (let iter (((list-headed-by <object>) values (cdr values))) (cond ((null? (cdr values)) (list ", or " (get-descr (car values)) "?")) (else (cons ", " (cons (get-descr (car values)) (iter (cdr values))))))))) (interactive-command self (function ((<description> descr)) (apply (function ((<symbol> modifier) (<description> descr)) (let (((list-of <object>) new-values (filter-descr descr values get-descr)) (<boolean> multiple? (eq? modifier 'all))) (cond ((null? new-values) (list #f '())) ((and multiple? (not slot-multiple?)) (output "Multiple objects not " "allowed in this context.") (list #t (iter #t #f values))) (else (list #t (iter #t multiple? new-values)))))) (cond ((null? descr) (list 'a '())) ((memq (car descr) '(a an all the)) (list (car descr) (cdr descr))) (else (list 'a descr))))) #t)))))))) (cond ((boolean? next-value) next-value) (else (iter (cdr slots) (cdr assigned?) (cdr multiple?) (cdr values) (cons next-value done-values))))))))) (fglobal remove-duplicates (function (((list-of <object>) values) (<function> get-descr)) (if (null? values) '() (let* ((<description> name (get-descr (car values))) ((list-of <object>) matches (filter (function ((<object> value)) (equal? (get-descr value) name)) values))) (cons (random-element matches) (remove-duplicates (filter (function ((<object> value)) (not (equal? (get-descr value) name))) (cdr values)) get-descr))))))

actions.betty

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ACTIONS.BETTY ;;; The action database (commands interactives can perform.) ;;; ;;; You CANNOT modify this file in any way. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (reset-actions!) (add-action! (make-action '(rest sleep wait) '() regen-hps!)) (add-action! (make-action '(move walk wander) '() move)) (add-action! (make-action '(quit halt bye goodbye) '() (function ((<animate> a)) (output "Okay, finishing up...") (rebind! *quit* #t)))) (add-action! (make-action '(shoot fire) (list (make-slot '(with ()) (function ((<interactive> self)) (filter (function ((<adventure-object> object)) (instance-of? <gun> object)) (possessions self))) name #f #f "What do you want me to shoot with?" "I don't seem to have a gun." "I can't find that gun.") (make-slot '(at ()) (function ((<interactive> self)) (filter (function ((<adventure-object> object)) (and (instance-of? <animate> object) (not (eq? object self)))) (possessions (possessor self)))) name #f #f "What do you want me to shoot at?" "I don't seem to have any targets around." "I don't see who you want me to shoot at.")) (function ((<interactive> self) (<gun> gun) (<animate> target)) (attack-with gun target) #t))) (fglobal add-direction-action! (function ((<list> direction-list)) (let ((<symbol> true-direction (car direction-list))) (add-action! (make-action direction-list (list (make-slot '(to) (function ((<interactive> self)) (get-exits self true-direction)) (function ((<exit> exit)) (name (exit-place exit))) #f #f "Where do you want me to go?" "I don't see any way to go in that direction!" "That isn't an exit in that direction!")) (function ((<interactive> self) (<exit> exit)) (go-to self (exit-place exit)))))))) (fglobal get-exits (function ((<interactive> self) (<symbol> true-direction)) (filter (function ((<exit> exit)) (eq? (exit-dir exit) true-direction)) (let ((<adventure-object> place (possessor self))) (if (instance-of? <place> place) (exits place) '()))))) (add-direction-action! '(north n)) (add-direction-action! '(northeast ne)) (add-direction-action! '(east e)) (add-direction-action! '(southeast se)) (add-direction-action! '(south s)) (add-direction-action! '(southwest sw)) (add-direction-action! '(west w)) (add-direction-action! '(northwest nw)) (add-direction-action! '(up u)) (add-direction-action! '(down d)) (add-direction-action! '(out exit)) (add-action! (make-action '(enter) (list (make-slot '(()) (function ((<interactive> self)) (filter (function ((<exit> exit)) (eq? (exit-dir exit) 'in)) (let ((<adventure-object> place (possessor self))) (if (instance-of? <place> place) (exits place) '())))) (function ((<exit> exit)) (name (exit-place exit))) #f #f "What do you want me to enter?" "There is nothing to enter!" "I can't enter that from here!")) (function ((<interactive> self) (<exit> exit)) (go-to self (exit-place exit))))) (add-action! (make-action '(greet hello) (list (make-slot '(()) (function ((<interactive> self)) (filter (function ((<item> neighbor)) (and (instance-of? <animate> neighbor) (not (eq? neighbor self)))) (possessions (possessor self)))) name #f #t "Whom shall I greet?" "There's no one here!" "I can't greet someone I don't see!")) (function ((<interactive> self) ((list-of <animate>) neighbors)) (for-each (function ((<animate> neighbor)) (greet neighbor self)) neighbors) #f))) (add-action! (make-action '(get pickup take) (list (make-slot '(()) (function ((<interactive> self)) (let ((<adventure-object> place (possessor self))) (if (instance-of? <place> place) (filter (function ((<item> item)) (not (eq? self item))) (possessions place)) '()))) name #f #t "What shall I pickup?" "I can't pick anything up!" "I can't get someone I don't see!")) (function ((<interactive> self) ((list-of <item>) items)) (for-each (function ((<item> item)) (pickup item self)) items) #f))) (add-action! (make-action '(drop put) (list (make-slot '(()) (function ((<interactive> self)) (possessions self)) name #f #t "What shall I drop?" "I don't have anything!" "I can't drop somthing I don't have!")) (function ((<interactive> self) ((list-of <item>) items)) (for-each (function ((<item> item)) (drop item self)) items) #f))) (add-action! (make-action '(eat) (list (make-slot '(()) (function ((<interactive> self)) (filter (function ((<item> item)) (instance-of? <edible> item)) (possessions self))) name #f #t "What shall I eat?" "I don't have anything to eat!" "I can't eat someone I don't have!")) (function ((<interactive> self) ((list-of <item>) items)) (for-each (function ((<item> item)) (eat item self)) items) #f))) (add-action! (make-action '(l look) '() (function ((<interactive> self)) (look-around self) #f))) (add-action! (make-action '(i inventory) (list (make-slot '(() of) (function ((<interactive> self)) (if (instance-of? <place> (possessor self)) (possessions (possessor self)) (list self))) name #t #f "Whose goods shall I inventory?" "There's no one around." "I can't inventory a person's goods when they are not in sight")) (generic (function ((<interactive> self) (() nothing)) (let (((list-of <item>) items (possessions self))) (cond ((null? items) (output "You are empty handed.")) (else (output "You are carrying:") (for-each (function ((<item> item)) (output " " (name item))) items)))) #f) (function ((<interactive> self) (<item> item)) (let (((list-of <item>) items (possessions item))) (cond ((null? items) (output (name item) " isn't holding anything.")) (else (output (name item) " is carrying:") (for-each (function ((<item> item)) (output " " (name item))) items)))) #f)))) (add-action! (make-action '(hps health diagnose) (list (make-slot '(() of) (function ((<interactive> self)) (if (instance-of? <place> (possessor self)) (filter (function ((<item> item)) (instance-of? <animate> item)) (possessions (possessor self))) (list self))) name #t #f "Whose health shall I diagnose?" "There's no one around." "I can't diagnose a person's health when they are not in sight")) (generic (function ((<interactive> self) (() nothing)) (output "You have " (slot-ref self hps) " hit-points out of " (slot-ref self max-hps)) #f) (function ((<interactive> self) (<animate> animate)) (output (name animate) " has " (slot-ref animate hps) " hit-points out of " (slot-ref animate max-hps)) #f)))) (add-action! (make-action '(attack) (list (make-slot '(()) (function ((<interactive> self)) (filter (function ((<adventure-object> object)) (and (instance-of? <animate> object) (not (eq? object self)))) (possessions (possessor self)))) name #f #f "What do you want me to attack?" "I don't seem to have any targets around." "I don't see who you want me to attack.") (make-slot '(with) (function ((<interactive> self)) (filter (function ((<adventure-object> object)) (instance-of? <lethal> object)) (possessions self))) name #f #f "What do you want me to shoot with?" "I don't seem to have a weapon." "I can't find that weapon.")) (function ((<interactive> self) (<animate> target) (<lethal> lethal)) (attack-with lethal target) #t)))

solution.betty

;;; Problem 1: Getting started ;;; ;;; This is the function that adds all items to the world when the game starts. ;;; You will be changing this function for every problem. However, please hand ;;; in the function for problem 1 only, and your modifications for problem 2. ;;; You do not have to hand in any part of this function for problems 3 - 7. (fglobal add-items (function () (rebind! *items* '()) ;; Put objects in their initial locations. (start-at-place (instance <prof> name '(ramin)) '(ramins office)) (start-at-place (instance <staff> name '(don )) '(dons office)) (start-at-place (instance <staff> name '(justin )) '(justins office)) (start-at-place (instance <dog> name '(bismark)) '(central campus)) (start-at-place (instance <proprietor> name '(mrs oliver) constructor (function () (instance <beer>))) '(olivers beer store)) (start-at-place (instance <proprietor> name '(bob) constructor (function () (instance <pizza>))) '(johnnys hot truck)) (start-at-place (instance <proprietor> name '(mr dude behind the counter) constructor (function () (instance <assault-rifle>))) '(collegetown convenience store)) (start-at-place (instance <proprietor> name '(ms lady-at-the-cash-register) constructor (function () (instance <armor> name (random-element '((cornell sweatshirt) (cornell baseball cap) (cornell boxer shorts) (cornell sweatsocks)))))) '(campus store)) ;; Add your objects here! (start-at-place (instance <cop> name '(officer friendly)) '(college town)) (start-at-place (instance <dean> name '(dean hopcroft)) '(campus store)) (start-at-place (instance <money>) '(buffalo street)) )) ;;; Problem 2: Bursar ;;; ;;; A money grubbing part of your favorite campus (class <bursar> () () <monster>) ;;; Problem 3: Barney ;;; (class <dinosaur> () (function ((<dinosaur> dino)) (cnf) (slot-rebind! dino max-hps 30)) <animate>) (class <barney> () () <dinosaur>) ;;; Problem 4: Barney Hunters ;;; ;;; A BARNEY-HUNTER is a student who goes around hunting barney. ;;; They started by hunting for an ear plug, a weapon, and then hunt Barney down. (class <barney-hunter> () () <student>) ;;; Problem 5: Triceratops ;;; ;;; The TRICERATOPS class is a subclass of the DINOSAUR class and PLACE class. ;;; Triceratops walked around Ithaca, and can be ridden. ;;; Instead of talking, they just roar. (class <triceratops> () () <dinosaur> <place>)