yellowpigs.net

Text Adventure in Computer Services

; Sara Smollett

; sara.ss

; the uncommented version

; yes, there really was a commented version

; with thanks to C.H.

 

(define nl (list->string '(#\newline)))

(define dn (lambda x '()))

 

(define string-loc

(lambda (str k)

(letrec ((sl-h

(lambda (str acc)

(cond ((zero? (string-length str)) -1)

((equal? (string-ref str 0) k) acc)

(else (sl-h (substring str 1 (string-length str))

(add1 acc)))))))

(sl-h str 0))))

 

(define remove-voids

(lambda (str)

(cond ((null? str) '())

((void? (car str)) (remove-voids (cdr str)))

(else (cons (car str) (remove-voids (cdr str)))))))

 

(define exchange-blows

(lambda (attacker victim)

(let ((at-damage (random (attacker 'get-hp)))

(vic-damage (random (victim 'get-hp))))

(victim 'sub-hp at-damage)

(if (victim 'is-dead)

(victim 'die)

(begin

(attacker 'sub-hp vic-damage)

(if (attacker 'is-dead)

(attacker 'die)

(string-append

"You bonk "

(string-append

(victim 'get-sdesc)

(string-append

" for "

(string-append

(number->string at-damage)

(string-append

" and it bonks you back for "

(string-append

(number->string vic-damage)

"."))))))))))))

 

(define make-creature

(lambda ()

(letrec ((names '())

(sdesc "")

(ldesc "")

(hp 0)

(items '())

(room 0)

(interface dn)

(this

(lambda x

(case (length x)

('0 (void))

('1

(case (car x)

('get-names names)

('get-sdesc sdesc)

('get-ldesc ldesc)

('get-hp hp)

('get-items items)

('get-room room)

('get-interface interface)

('is-dead (if (< hp 0) #t #f))

('die (if (not (number? room))

(begin

(room 'remove-creature this)

(let ((cur-items (room 'get-items)))

(room 'set-items (append

cur-items

(this 'get-items)))

(map

(lambda (obj)

(obj 'set-room room))

(this 'get-items)))

(set! room 0)

(string-append

(this 'get-sdesc) " says, 'Ack, I'm DEAD!'"))))

(else (void))))

('2

(case (car x)

('add-name (set! names (cons (cadr x) names)))

('set-names (set! names (cadr x)))

('remove-name (set! names (remove (cadr x) names)))

('is-name (if (member (cadr x) names)

#t #f))

('set-sdesc (set! sdesc (cadr x)))

('set-ldesc (set! ldesc (cadr x)))

('add-hp (set! hp (+ hp (cadr x))))

('sub-hp (set! hp (- hp (cadr x))))

('set-hp (set! hp (cadr x)))

('add-item (set! items (cons (cadr x) items)))

('remove-item (set! items (remove (cadr x) items)))

('set-items (set! items (cadr x)))

('set-interface (set! interface (cadr x)))

('set-room (set! room (cadr x)))

('move (begin

(room 'remove-creature this)

(this 'set-room (cadr x))

(room 'add-creature this)))

(else (void))))

(else (void))))))

this)))

 

(define make-player

(lambda ()

(letrec ((status '())

(super (make-creature))

(this

(lambda x

(case (length x)

('0 (void))

('1

(case (car x)

('get-status status)

('die

(begin

(newline)

(display "OH NO!! You're DEAD!")

(newline)

(display "Play again? ")

(let ((iput (read)))

(if (member iput '(y yes Y Yes YES))

(game)

(begin

(finis)

(stop))))))

(else (apply super x))))

('2

(case (car x)

('set-status (set! status (cadr x)))

('add-status (set! status (cons (cadr x) status)))

('remove-status (set! status (remove (cadr x) status)))

(else (apply super x))))

(else (apply super x))))))

this)))

 

(define make-room

(lambda ()

(letrec ((name "")

(desc "")

(exits '())

(items '())

(creatures '())

(interface dn)

(this

(lambda x

(case (length x)

('0 (void))

('1

(case (car x)

('get-name name)

('get-desc desc)

('get-exits exits)

('get-items items)

('get-creatures creatures)

('get-interface interface)))

('2

(case (car x)

('set-name (set! name (cadr x)))

('set-desc (set! desc (cadr x)))

('set-exits (set! exits (cadr x)))

('add-exit (set! exits (cons (cadr x) exits)))

('remove-exit (set! exits (remove (assoc (cadr x) exits) exits)))

('set-items (set! items (cadr x)))

('add-item (set! items (cons (cadr x) items)))

('remove-item (set! items (remove (cadr x) items)))

('set-creatures (set! creatures (cadr x)))

('add-creature (set! creatures (cons (cadr x) creatures)))

('remove-creature (set! creatures (remove (cadr x) creatures)))

('set-interface (set! interface (cadr x)))))

(else (void))))))

this)))

 

(define make-item

(lambda ()

(letrec ((names '())

(sdesc "")

(ldesc "")

(room 0)

(interface dn)

(this

(lambda x

(case (length x)

('0 (void))

('1

(case (car x)

('get-names names)

('get-sdesc sdesc)

('get-ldesc ldesc)

('get-room room)

('get-interface interface)))

('2

(case (car x)

('set-names (set! names (cadr x)))

('add-name (set! names (cons (cadr x) names)))

('remove-name (set! names (remove (cadr x) names)))

('is-name (if (member (cadr x) names) #t #f))

('set-sdesc (set! sdesc (cadr x)))

('set-ldesc (set! ldesc (cadr x)))

 

('set-room (set! room (cadr x)))

('put (begin

(this 'set-room (cadr x))

((cadr x) 'add-item this)))

('set-interface (set! interface (cadr x)))))

(else (void))))))

this)))

 

(define dew

(lambda (verb noun)

(let* ((p-room (player 'get-room))

(p-items (player 'get-items))

(r-creas (p-room 'get-creatures))

(r-items (p-room 'get-items))

(m-output

(map

(let ((done-anything #f))

(lambda (iface)

(if (not done-anything)

(let ((res (iface verb noun)))

(if (not (null? res))

(begin

(set! done-anything #t)

res))))))

`(,(player 'get-interface)

,@(map

(lambda (obj)

(obj 'get-interface))

p-items)

,(p-room 'get-interface)

,@(map

(lambda (crea)

(crea 'get-interface))

r-creas)

,@(map

(lambda (obj)

(obj 'get-interface))

r-items)))))

(set! m-output (remove-voids m-output))

(if (not (null? m-output))

(car m-output)

(if (null? noun)

(case verb

((l look)

(let ((desc (string-append

(p-room 'get-name)

(string-append

nl

(string-append

(p-room 'get-desc) nl)))))

(map

(lambda (obj)

(set! desc

(string-append

desc (string-append

(obj 'get-ldesc) nl))))

(append (p-room 'get-items) (p-room 'get-creatures)))

(set! desc (substring desc 0 (sub1 (string-length desc))))

desc))

((n north s south e east w west u up d down)

(let ((apair (assoc

(case verb

((n north) 'n)

((s south) 's)

((e east) 'e)

((w west) 'w)

((u up) 'u)

((d down) 'd))

(p-room 'get-exits))))

(if apair

(begin

(player 'move (cadr apair))

(dew 'look '()))

"I'm sorry, you can't go that way.")))

((i inventory)

(let ((res ""))

(map

(lambda (obj)

(set!

res (string-append

res (string-append

(obj 'get-sdesc) nl))))

(player 'get-items))

(string-append

"You are carrying:" (string-append

nl res))))

('quit (begin

(finis)

(stop)))

(else "I'm too stupid to do that."))

(case verb

((get take) (let ((r-items (p-room 'get-items))

(got-anything #f))

(map

(lambda (obj)

(if (member noun (obj 'get-names))

(begin

(p-room 'remove-item obj)

(player 'add-item obj)

(display "Picked up ")

(display (obj 'get-sdesc))

(newline)

(set! got-anything #t))))

r-items)

(if got-anything

"OK."

"I don't see that here.")))

('drop (let ((p-items (player 'get-items))

(got-anything #f))

(map

(lambda (obj)

(if (member noun (obj 'get-names))

(begin

(player 'remove-item obj)

(p-room 'add-item obj)

(display "Dropped ")

(display (obj 'get-sdesc))

(newline)

(set! got-anything #t))))

p-items)

(if got-anything

"OK."

"You don't have that.")))

((kill hit)

(let ((r-creas (p-room 'get-creatures))

(victim #f))

(map

(lambda (crea)

(if (not victim)

(if (crea 'is-name noun)

(set! victim crea))))

r-creas)

(if (not victim)

"You don't see that here."

(exchange-blows player victim))))

((look l)

(let ((rel-objs (append (player 'get-items)

(p-room 'get-items)))

(rel-creas (p-room 'get-creatures))

(saw-something #t)

(res '())

(res2 "")

(res3 ""))

(map

(lambda (obj)

(if saw-something

(if (obj 'is-name noun)

(begin

(set! saw-something #f)

(set! res (obj 'get-ldesc))))))

rel-objs)

 

(if (null? res)

(begin

(map

(lambda (crea)

(if saw-something

(if (crea 'is-name noun)

(begin

(set! saw-something #f)

(set! res (crea 'get-ldesc))

(set! res2 (crea 'get-hp))

(set! res3 (crea 'get-items))))))

rel-creas)

(if (null? res)

"You don't see that here."

(string-append

res

(string-append

nl

(string-append

"It has "

(string-append

(number->string res2)

(string-append

" hit points."

(string-append

nl

(string-append

"Carrying: "

(let ((output ""))

(map

(lambda (itm)

(set! output

(string-append

output

(string-append

(itm 'get-sdesc) " "))))

res3)

output))))))))))

res)))

(else "I'm too stupid to do that.")))))))

(define player (make-player))

 

(define loop

(lambda ()

(display

(string-append

"[ "

(string-append

(number->string (player 'get-hp))

" ]> ")))

(let ((c 42))

(call/cc (lambda (k) (set! c k)))

(let ((input (read-line)))

(if (zero? (string-length input))

(c)

(let* ((first-space (string-loc input #\space))

(matches (regexp-match (regexp "[a-zA-Z0-9]+")

(substring input 0

(if (= first-space -1)

(string-length input)

first-space))))

(verb (if (not matches)

(loop)

(string->symbol

(car matches))))

(rest-str (if (= first-space -1)

" "

(substring input first-space (string-length input))))

(output

(if (string>? rest-str (make-string 255 #\space))

(dew verb

(string->symbol

(car (regexp-match (regexp "[a-zA-Z0-9]+")

rest-str))))

(dew verb '()))))

(newline) (display output) (newline)

(loop)))))))

(define game

(lambda ()

(display "Spec file to load: ")

(let* ((file-sym (read))

(file-str (symbol->string file-sym)))

(if (file-exists? file-str)

(load file-str)

(game))

(player 'set-room start)

(start 'add-creature player)

(player 'set-hp 100)

(intro)

(newline)

(display (dew 'look '())) (newline)

(loop))))

 

(define stop 42)

(call/cc (lambda (k) (set! stop k)))

 

;;;;;;;;

 

;sara_data.ss, a data file for a 7-room computer services theme.

 

; messages to be displayed at the beginning and end of game.

(define intro

(lambda ()

(display "Welcome to -") (newline)

(display "SARA'S FINAL PROJECT!!!") (newline)))

 

(define finis

(lambda ()

(display "Thank you for playing!")))

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 1.

(define rm1 (make-room))

(rm1 'set-name "Computer Services")

(rm1 'set-desc

"This is the heart of the college - except most people don't know it.

From here, the slow takeover has begun, and tentacles of control have

crept out, until now Bernie can't sneeze without these people's

permission. The only threat is Mark's empire, which encroaches

in the form of barbarian attacks from the east.

The implements of desctruction range about you, as well as the

implementors. To the north is a hulking black cube known as the NeXT,

while cubicles range to the west and south. The Rest Of The World is

out to the east.")

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 2. Item: the NeXT. Interface: the NeXT.

(define rm2 (make-room))

(rm2 'set-name "The NeXT Station")

(rm2 'set-desc

"It's black. It's a cube. And other than that... it doesn't do

much. This little beastie of a computer is the height of ten year old

technology. And right now, Plato could probably beat it up. But hey,

we keep it around to make into a planter some day - some potting soil,

and it'll be right up to shape. You can escape obsolescence to the

south.")

 

(define it1 (make-item))

(it1 'set-names '(next NeXT machine computer black cube))

(it1 'set-sdesc "the NeXT")

(it1 'set-ldesc "A black NeXT computer churns away here.")

(it1 'set-interface ;; an interface associated with an item

(lambda (verb noun)

(if (null? noun)

'()

(case verb

('type

(if (it1 'is-name noun) ;; if "type next"

"You click away at a few keys. It beeps."

'()))

((l look)

(if (it1 'is-name noun) ;; if "look next"

"It's a cube, silly, and black and stuff. We told you that already,

remember? What, do you want to see it naked or something?"

'()))

((get take)

(if (it1 'is-name noun) ;; if "get next"

"It's cool, but you can't take it. Sorry."

'()))

(else '())))))

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 3. Creature: Alice. Interface: Alicebert's Cubicle, Alice.

(define rm3 (make-room))

(rm3 'set-name "Alicebert's Cubicle")

(rm3 'set-desc

"This is Alice's little home away from home. There's not really much

room here, though, because her computer takes up most of the space.

For that matter, it takes up most of the budget, too. Alice's

computer's net worth is not only more than the rest of computer

services, but probably the college itself. Don't breathe on

it funny - it's worth more than you are, too. There appears to be

another cubicle to the west, and the rest of the room to the east.")

(rm3 'set-interface ;; an interface associated with the room

(lambda (verb noun)

(if (null? noun)

'()

(case verb

((l look)

(case noun

((computer machine) ;; if "look computer"

"It's big. It has a 32 inch monitor, the tower goes higher than your

head, and if you bump into it it'll probably fall over and squish you.

Don't even THINK about touching it!")

(else '())))

(else '())))))

 

(define cr1 (make-creature))

(cr1 'set-names '(alice Alice alicebert myers media coordinator))

(cr1 'set-sdesc "Alice")

(cr1 'set-ldesc "Alice Myers, the media coordinator, stares at

her computer.")

(cr1 'set-hp 75)

(cr1 'set-interface ;; interface associated with creature

(lambda (verb noun)

(if (null? noun)

'()

(if (cr1 'is-name noun) ;; if noun is alice, talk...

(begin

(display

(case (random 5)

('0 "Alice asks, 'What color should the walls be?'")

('1 "She looks around and says, 'I think the walls

should be purple, or red, or...'")

('2 "She jumps up and down and says, 'Let's order

something!'")

('3 "Alice is too busy filling out a media assistant

timesheet to answer.")

('4 "'Ok David, whatever you think...'")))

(newline) '())

'()))))

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 4. Creature: David. Item: Key. Interface: David.

(define rm4 (make-room))

(rm4 'set-name "The Pointy Eyebrowed Boss's Cubicle")

(rm4 'set-desc "David is often out of the office, but his office is full

of good O'Reilly books to read while he is away. His desk is cluttered

with important papers even though he has a student secretary

to take care of it. Sometimes he loses his keys on his desk.

Alicebert's cubicle is to the east, on the other side of a partition.")

 

(define cr2 (make-creature))

(cr2 'set-names '(david reed David dreed boss pointy peb emperor))

(cr2 'set-sdesc "David")

(cr2 'set-ldesc "Emperor David Reed rules here from his orthopedic

chair.")

(cr2 'set-hp 100)

(cr2 'set-interface ;; interface associated with a creature

(lambda (verb noun)

(if (null? noun)

'()

(if (cr2 'is-name noun) ;; if noun is david, talk...

(begin

(display

(case (random 10)

('0 "'North and south are things most people have

heard of.'")

('1 "'I've never actually had joe, but a stupid editor

is a stupid editor.'")

('2 "'I didn't parse that very effectively.'")

('3 "'Windows 98 is incompatible with the network.'")

('4 "'Ask me that again using different words.'")

('5 "'One of the ways you get to be king is by showing

up for work early.'")

('6 "'My mother is older than I am, you know.'")

('7 "'This is my wife Sara. My wife's name COULD be

Sara... or maybe her middle name.'")

('8 "'Shocks are just like JSHAAAAA!'")

('9 "'We were trying to get rid of Plato but it's so

old it might collapse.'")))

(newline) '())

'()))))

 

(define it4 (make-item))

(it4 'set-names '(key keys keyring keychain))

(it4 'set-sdesc "the keys")

(it4 'set-ldesc "A HUGE ring of keys is sprawled here.")

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 5. Creature: Karl. Item: Penguin. Interface: Karl, Penguin.

(define rm5 (make-room))

(rm5 'set-name "Karlbert's Cubicle")

(rm5 'set-desc

"You are in Karl's cubicle in the back corner of the office. The room

smells strongly of altoids. An adorable replica of Tux sits on a linux

box. When Karl is actually in the office, he doesn't like being distracted

from his computer games by lusers, so don't bother him. If you ask him for

help, you will probably just become more confused. The locked machine

room is west.")

 

(define cr3 (make-creature))

(cr3 'set-names '(karl Karl Krueger bofh karlbert kjarl schmoo))

(cr3 'set-sdesc "Karl")

(cr3 'set-ldesc "Karl Krueger, BOFH, plays ADOM here.")

(cr3 'set-hp 90)

(cr3 'set-interface ;; interface associated with a creature

(lambda (verb noun)

(if (null? noun)

'()

(case verb

((get take)

(if (it2 'is-name noun) ;; if "take penguin"

"Karl growls. 'Toucheth not the saviour penguin of the world.'"

'()))

(else (if (cr3 'is-name noun) ;; if noun is karl, talk...

(begin

(display

(case (random 12)

('0 "'Foo.'")

('1 "'Clue.'")

('2 "'Mew.'")

('3 "'Schmoo.'")

('4 "'Marf.'")

('5 "'Yibble.'")

('6 "'Freud.'")

('7 "'Yermom.'")

('8 "'Bite me.'")

('9 "'Luser.'")

('10 "'Crackhead.'")

('11 "'I am not a goth.'")

(newline) '())

'()))))))

 

(define it2 (make-item))

(it2 'set-names '(penguin doll tux))

(it2 'set-sdesc "a penguin")

(it2 'set-ldesc "Tux the penguin is here. Well, a stuffed doll of him

is.")

(it2 'set-interface ;; interface associated with an item

(let ((tied-up #f))

(lambda (verb noun)

(if (null? noun)

'()

(case verb

((tie hang strangle)

(if (it2 'is-name noun) ;; if "tie pengin"

(if tied-up

"Tux is already gasping his last. *gasp*"

(begin

(set! tied-up #t)

"You grab a handy patch cable and string the

poor bird up."))

'()))

((untie loose free)

(if (it2 'is-name noun) ;; if "untie penguin"

(if tied-up

(begin

(set! tied-up #f)

"You release Tux to the OSS community. Tux is

free!")

"Tux is already free. That's why Microsoft

doesn't like him.")

'()))

((hug kiss cuddle snuggle)

(if (it2 'is-name noun) ;; if "kiss penguin"

(if tied-up

"Tux is into bondage."

"You snuggle up to the fuzzy little critter.")

'()))

(else '()))))))

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 6. Item: a 95 CD.

(define rm6 (make-room))

(rm6 'set-name "The Machine Room")

 

(rm6 'set-desc

"The machine room is where all of the computer services servers (and

even a library server) reside. Plato, a Sun Sparc 10, sits in one

corner. The small room is a clutter of computers, electrical chords,

fiber, and cat 5. Be careful not to trip. A beat-up Windows 95 CD is on

a desk. Karlbert's cubicle lies to the east.")

 

(define it3 (make-item))

(it3 'set-names '(windows 95 cd Windows CD))

(it3 'set-sdesc "a 95 CD")

(it3 'set-ldesc "A Windows 95 CD pollutes the space here.")

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; Room 7.

(define rm7 (make-room))

(rm7 'set-name "The Rest of Simon's Rock")

(rm7 'set-desc

"Outside the basement, it's nice and sunny. Students talk as they go to

classes. Bernie, the dean, smokes a cigarette. Computer

Services is west.")

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

; set some exits

(rm1 'set-exits `((n ,rm2) (w ,rm3) (s ,rm5) (e ,rm7)))

(rm2 'set-exits `((s ,rm1)))

(rm3 'set-exits `((e ,rm1) (w ,rm4)))

(rm4 'set-exits `((e ,rm3)))

(rm5 'set-exits `((n ,rm1) (w ,rm6)))

(rm6 'set-exits `((e ,rm5)))

(rm7 'set-exits `((w ,rm1)))

 

; put items in rooms or give to creatures

(it1 'put rm2)

(it2 'put rm5)

(it3 'put rm6)

(cr2 'add-item it4)

 

; pair creatures and rooms

(cr1 'set-room rm3)

(rm3 'add-creature cr1)

(cr2 'set-room rm4)

(rm4 'add-creature cr2)

(cr3 'set-room rm5)

(rm5 'add-creature cr3)

 

; need a first room

(define start rm1)