(use-modules (mudsync)
(mudsync container)
(8sync)
+ (8sync daydream)
(oop goops)
(ice-9 control)
(ice-9 format)
(for-each
(lambda (obj-sym)
(define obj-id (dyn-ref gameobj obj-sym))
- (define goes-by
- (mbody-val (<-wait obj-id 'goes-by)))
+ (define goes-by (<-wait obj-id 'goes-by))
(when (ci-member direct-obj goes-by)
(<- obj-id 'cmd-take #:direct-obj direct-obj #:player player)
(escape #f)))
(define* (sign-cmd-sign-in actor message
#:key direct-obj indir-obj preposition)
- (define old-name
- (mbody-val (<-wait (message-from message) 'get-name)))
+ (define old-name (<-wait (message-from message) 'get-name))
(define name indir-obj)
(if (valid-name? indir-obj)
(begin
;; and find out their name. We'll call *their* get-name message
;; handler... meanwhile, this procedure suspends until we get
;; their response.
- (define who-rang
- (mbody-val (<-wait (message-from message) 'get-name)))
+ (define who-rang (<-wait (message-from message) 'get-name))
;; Now we'll invoke the "tell" message handler on the player
;; who rang us, displaying this text on their screen.
completely separate, glowing copy of the disc materializes into your
hands!")))
(<- (gameobj-loc gameobj) 'tell-room
- #:text `(,(mbody-val (<-wait player 'get-name))
- " pulls on the shield of the statue, and a glowing "
- "copy of it materializes into their hands!")
- #:exclude player)
+ #:text `(,(<-wait player 'get-name)
+ " pulls on the shield of the statue, and a glowing "
+ "copy of it materializes into their hands!")
+ #:exclude player)
(<- (gameobj-loc gameobj) 'tell-room
#:text
'(p "You hear a voice whisper: "
(player (message-from message)))
(<- player 'tell
#:text "You drop the glowing disc, and it shatters into a million pieces!")
- (<- (mbody-val (<-wait player 'get-loc)) 'tell-room
- #:text `(,(mbody-val (<-wait player 'get-name))
+ (<- (<-wait player 'get-loc) 'tell-room
+ #:text `(,(<-wait player 'get-name)
" drops a glowing disc, and it shatters into a million pieces!")
#:exclude player)
(gameobj-self-destruct gameobj))
;;; Playroom
;;; --------
+(define-actor <rgb-machine> (<gameobj>)
+ ((cmd-run rgb-machine-cmd-run)
+ (cmd-reset rgb-machine-cmd-reset))
+ (commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ (("run" "start") ((direct-command cmd-run)))
+ ("reset" ((direct-command cmd-reset)))))
+ (resetting #:init-value #f
+ #:accessor .resetting)
+ ;; used to reset, and to kick off the first item in the list
+ (rgb-items #:init-keyword #:rgb-items
+ #:accessor .rgb-items))
+
+(define (rgb-machine-cmd-run rgb-machine message . _)
+ (define player (message-from message))
+ (<-wait player 'tell
+ #:text '("You start the rube goldberg machine."))
+ (<-wait (gameobj-loc rgb-machine) 'tell-room
+ #:text `(,(<-wait player 'get-name)
+ " runs the rube goldberg machine.")
+ #:exclude player)
+ (daydream 1)
+ (match (.rgb-items rgb-machine)
+ ((first-item rest ...)
+ (<- (dyn-ref rgb-machine first-item) 'trigger))))
+
+(define (rgb-machine-cmd-reset rgb-machine message . _)
+ (define player (message-from message))
+ (cond
+ ((not (.resetting rgb-machine))
+ (set! (.resetting rgb-machine) #t)
+ (<-wait player 'tell
+ #:text '("You reset the rube goldberg machine."))
+ (<-wait (gameobj-loc rgb-machine) 'tell-room
+ #:text `(,(<-wait player 'get-name)
+ " resets the rube goldberg machine.")
+ #:exclude player)
+ (<-wait (gameobj-loc rgb-machine) 'tell-room
+ #:text '("From a panel in the wall, a white gloved mechanical "
+ "arm reaches out to reset all the "
+ "rube goldberg components."))
+ (daydream (/ 1 2))
+ (for-each
+ (lambda (rgb-item)
+ (<- (dyn-ref rgb-machine rgb-item) 'reset)
+ (daydream (/ 1 2)))
+ (.rgb-items rgb-machine))
+ (<- (gameobj-loc rgb-machine) 'tell-room
+ #:text "The machine's mechanical arm retreats into the wall!")
+ (set! (.resetting rgb-machine) #f))
+ (else
+ (<-wait player 'tell
+ #:text '("But it's in the middle of resetting right now!")))))
+
+(define-actor <rgb-item> (<gameobj>)
+ ((trigger rgb-item-trigger)
+ (reset rgb-item-reset))
+ (invisible? #:init-value #t)
+ (steps #:init-keyword #:steps
+ #:accessor .steps)
+ (triggers-as #:init-value #f
+ #:init-keyword #:triggers-as
+ #:getter .triggers-as)
+ (reset-msg #:init-keyword #:reset-msg
+ #:getter .reset-msg)
+ ;; States: ready -> running -> ran
+ (state #:init-value 'ready
+ #:accessor .state))
+
+
+(define (rgb-item-trigger rgb-item message . _)
+ (define room (gameobj-loc rgb-item))
+ (case (.state rgb-item)
+ ((ready)
+ ;; Set state to running
+ (set! (.state rgb-item) 'running)
+
+ ;; Loop through all steps
+ (for-each
+ (lambda (step)
+ (match step
+ ;; A string? That's the description of what's happening, tell players
+ ((? string? str)
+ (<- room 'tell-room #:text str))
+ ;; A number? Sleep for that many secs
+ ((? number? num)
+ (daydream num))
+ ;; A symbol? That's another gameobj to look up dynamically
+ ((? symbol? sym)
+ (<- (dyn-ref rgb-item sym) 'trigger
+ #:triggered-by (.triggers-as rgb-item)))
+ (_ (throw 'unknown-step-type
+ "Don't know how to process rube goldberg machine step type?"
+ #:step step))))
+ (.steps rgb-item))
+
+ ;; We're done! Set state to ran
+ (set! (.state rgb-item) 'ran))
+
+ (else
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " has already been triggered!")))))
+
+(define (rgb-item-reset rgb-item message . _)
+ (define room (gameobj-loc rgb-item))
+ (case (.state rgb-item)
+ ((ran)
+ (set! (.state rgb-item) 'ready)
+ (<- room 'tell-room
+ #:text (.reset-msg rgb-item)))
+ ((running)
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " is currently running!")))
+ ((ready)
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " has already been reset.")))))
+
+(define-actor <rgb-kettle> (<rgb-item>)
+ ((trigger rgb-kettle-trigger)
+ (reset rgb-kettle-reset))
+ (heated #:accessor .heated
+ #:init-value #f)
+ (filled #:accessor .filled
+ #:init-value #f))
+
+(define* (rgb-kettle-trigger rgb-item message #:key triggered-by)
+ (define room (gameobj-loc rgb-item))
+ (if (not (eq? (.state rgb-item) 'ran))
+ (begin
+ (match triggered-by
+ ('water-demon
+ (set! (.state rgb-item) 'running)
+ (set! (.filled rgb-item) #t))
+ ('quik-heater
+ (set! (.state rgb-item) 'running)
+ (set! (.heated rgb-item) #t)))
+ (when (and (.filled rgb-item)
+ (.heated rgb-item))
+ (<- room 'tell-room
+ #:text '((i "*kshhhhhh!*")
+ " The water has boiled!"))
+ (daydream .25)
+ (set! (.state rgb-item) 'ran)
+ ;; insert a cup of hot tea in the room
+ (create-gameobj <hot-tea> (gameobj-gm rgb-item) room)
+ (<- room 'tell-room
+ #:text '("The machine pours out a cup of hot tea! "
+ "Looks like the machine finished!"))))
+ (<- room 'tell-room
+ #:text `("... but " ,(slot-ref rgb-item 'name)
+ " has already been triggered!"))))
+
+(define (rgb-kettle-reset rgb-item message . rest-args)
+ (define room (gameobj-loc rgb-item))
+ (when (eq? (.state rgb-item) 'ran)
+ (set! (.heated rgb-item) #f)
+ (set! (.filled rgb-item) #f))
+ (apply rgb-item-reset rgb-item message rest-args))
+
+(define-actor <tinfoil-hat> (<gameobj>)
+ ((cmd-wear tinfoil-hat-wear))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("wear" ((direct-command cmd-wear))))))
+
+(define (tinfoil-hat-wear tinfoil-hat message . _)
+ (<- (message-from message) 'tell
+ #:text '("You put on the tinfoil hat, and, to be perfectly honest with you "
+ "it's a lot harder to take you seriously.")))
+
+
+(define-actor <hot-tea> (<gameobj>)
+ ((cmd-drink hot-tea-cmd-drink)
+ (cmd-sip hot-tea-cmd-sip))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk (build-commands
+ ("drink" ((direct-command cmd-drink)))
+ ("sip" ((direct-command cmd-sip)))))
+
+ (sips-left #:init-value 4
+ #:accessor .sips-left)
+ (name #:init-value "a cup of hot tea")
+ (take-me? #:init-value #t)
+ (goes-by #:init-value '("cup of hot tea" "cup of tea" "tea" "cup"))
+ (desc #:init-value "It's a steaming cup of hot tea. It looks pretty good!"))
+
+(define (hot-tea-cmd-drink hot-tea message . _)
+ (define player (message-from message))
+ (define player-loc (<-wait player 'get-loc))
+ (define player-name (<-wait player 'get-name))
+ (<- player 'tell
+ #:text "You drink a steaming cup of hot tea all at once... hot hot hot!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " drinks a steaming cup of hot tea all at once.")
+ #:exclude player)
+ (gameobj-self-destruct hot-tea))
+
+(define (hot-tea-cmd-sip hot-tea message . _)
+ (define player (message-from message))
+ (define player-loc (<-wait player 'get-loc))
+ (define player-name (<-wait player 'get-name))
+ (set! (.sips-left hot-tea) (- (.sips-left hot-tea) 1))
+ (<- player 'tell
+ #:text "You take a sip of your steaming hot tea. How refined!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " takes a sip of their steaming hot tea. How refined!")
+ #:exclude player)
+ (when (= (.sips-left hot-tea) 0)
+ (<- player 'tell
+ #:text "You've finished your tea!")
+ (<- player-loc 'tell-room
+ #:text `(,player-name
+ " finishes their tea!")
+ #:exclude player)
+ (gameobj-self-destruct hot-tea)))
+
+(define-actor <fanny-pack> (<container>)
+ ((cmd-take-from-while-wearing cmd-take-from)
+ (cmd-put-in-while-wearing cmd-put-in))
+ (contained-commands
+ #:allocation #:each-subclass
+ #:init-thunk
+ (build-commands
+ (("l" "look") ((direct-command cmd-look-at)))
+ ("take" ((prep-indir-command cmd-take-from-while-wearing
+ '("from" "out of"))))
+ ("put" ((prep-indir-command cmd-put-in-while-wearing
+ '("in" "inside" "into" "on")))))))
+
(define playroom
(lol
('playroom
,(if (eq? contents '())
" nothing! It's empty!"
`(ul ,(map (lambda (occupant)
- `(li ,(mbody-val
- (<-wait occupant 'get-name))))
+ `(li ,(<-wait occupant 'get-name)))
(gameobj-occupants toy-chest))))))))
#:take-from-me? #t
#:put-in-me? #t)
#:name "a rubber duck"
#:goes-by '("rubber duck" "duck")
#:take-me? #t
- #:desc "It's a yellow rubber duck with a bright orange beak.")))
+ #:desc "It's a yellow rubber duck with a bright orange beak.")
+
+ ('playroom:toy-chest:tinfoil-hat
+ <tinfoil-hat> 'playroom:toy-chest
+ #:name "a tinfoil hat"
+ #:goes-by '("tinfoil hat" "hat")
+ #:take-me? #t
+ #:desc "You'd have to be a crazy person to wear this thing!")
+
+ ('playroom:toy-chest:fanny-pack
+ <fanny-pack> 'playroom:toy-chest
+ #:name "a fanny pack"
+ #:goes-by '("fanny pack" "pack")
+ #:take-me? #t
+ #:desc
+ (lambda (toy-chest whos-looking)
+ (let ((contents (gameobj-occupants toy-chest)))
+ `((p "It's a leather fanny pack, so it's both tacky and kinda cool.")
+ (p "Inside you see:"
+ ,(if (eq? contents '())
+ " nothing! It's empty!"
+ `(ul ,(map (lambda (occupant)
+ `(li ,(<-wait occupant 'get-name)))
+ (gameobj-occupants toy-chest)))))))))
+
+ ;; Things inside the toy chest
+ ('playroom:toy-chest:fanny-pack:plastic-elephant
+ <gameobj> 'playroom:toy-chest:fanny-pack
+ #:name "a plastic elephant"
+ #:goes-by '("plastic elephant" "elephant")
+ #:take-me? #t
+ #:desc "It's a tiny little plastic elephant. Small, but heartwarming.")
+
+ ('playroom:rgb-machine
+ <rgb-machine> 'playroom
+ #:name "a Rube Goldberg machine"
+ #:goes-by '("rube goldberg machine" "machine")
+ #:rgb-items '(playroom:rgb-dominoes
+ playroom:rgb-switch-match
+ playroom:rgb-candle
+ playroom:rgb-catapult
+ playroom:rgb-water-demon
+ playroom:rgb-quik-heater
+ playroom:rgb-kettle)
+ #:desc "It's one of those hilarious Rube Goldberg machines.
+What could happen if you started it?")
+
+ ;; Dominoes topple
+ ('playroom:rgb-dominoes
+ <rgb-item> 'playroom
+ #:name "some dominoes"
+ #:goes-by '("dominoes" "some dominoes")
+ #:steps `("The dominoes topple down the line..."
+ 1
+ "The last domino lands on a switch!"
+ 1.5
+ playroom:rgb-switch-match)
+ #:reset-msg "The dominoes are placed back into position.")
+
+ ;; Which hit the switch and strike a match
+ ('playroom:rgb-switch-match
+ <rgb-item> 'playroom
+ #:name "a switch"
+ #:goes-by '("switch" "match")
+ #:steps `("The switch lights a match!"
+ ,(/ 2 3)
+ "The match lights a candle!"
+ 1.5
+ playroom:rgb-candle)
+ #:reset-msg "A fresh match is installed and the switch is reset.")
+ ;; which lights a candle and burns a rope
+ ('playroom:rgb-candle
+ <rgb-item> 'playroom
+ #:name "a candle"
+ #:goes-by '("candle")
+ #:steps `("The candle burns..."
+ (/ 2 3) ; oops!
+ "The candle is burning away a rope!"
+ 2
+ "The rope snaps!"
+ .5
+ playroom:rgb-catapult)
+ #:reset-msg "A fresh candle is installed.")
+ ;; which catapults a rock
+ ('playroom:rgb-catapult
+ <rgb-item> 'playroom
+ #:name "a catapult"
+ #:goes-by '("catapult")
+ #:steps `("The snapped rope unleashes a catapult, which throws a rock!"
+ 2
+ "The rock flies through a water demon, startling it!"
+ .5
+ playroom:rgb-water-demon
+ 2
+ "The rock whacks into the quik-heater's on button!"
+ .5
+ playroom:rgb-quik-heater)
+ #:reset-msg
+ '("A fresh rope is attached to the catapult, which is pulled taught. "
+ "A fresh rock is placed on the catapult."))
+ ;; which both:
+ ;; '- panics the water demon
+ ;; '- which waters the kettle
+ ('playroom:rgb-water-demon
+ <rgb-item> 'playroom
+ #:name "the water demon"
+ #:triggers-as 'water-demon
+ #:goes-by '("water demon" "demon")
+ #:steps `("The water demon panics, and starts leaking water into the kettle below!"
+ 3
+ "The kettle is filled!"
+ playroom:rgb-kettle)
+ #:reset-msg '("The water demon is scratched behind the ears and calms down."))
+ ;; '- bops the quik-heater button
+ ;; '- which heats the kettle
+ ('playroom:rgb-quik-heater
+ <rgb-item> 'playroom
+ #:name "the quik heater"
+ #:triggers-as 'quik-heater
+ #:goes-by '("quik heater" "heater")
+ #:steps `("The quik-heater heats up the kettle above it!"
+ 3
+ "The kettle is heated up!"
+ playroom:rgb-kettle)
+ #:reset-msg '("The quik heater is turned off."))
+ ;; Finally, the kettle
+ ('playroom:rgb-kettle
+ <rgb-kettle> 'playroom
+ #:name "the kettle"
+ #:goes-by '("kettle")
+ #:reset-msg '("The kettle is emptied."))))
\f
(define* (furniture-cmd-sit actor message #:key direct-obj)
(define player-name
- (mbody-val (<-wait (message-from message) 'get-name)))
+ (<-wait (message-from message) 'get-name))
(<- (message-from message) 'tell
#:text (format #f "You ~a ~a.\n"
(slot-ref actor 'sit-phrase)
(define* (clerk-cmd-dismiss clerk message . _)
(define player-name
- (mbody-val (<-wait (message-from message) 'get-name)))
+ (<-wait (message-from message) 'get-name))
(match (slot-ref clerk 'state)
('on-duty
(<- (gameobj-loc clerk) 'tell-room
(match (slot-ref clerk 'state)
('slacking
(tell-room (random-choice clerk-slacking-texts))
- (8sleep (+ (random 20) 15))
+ (daydream (+ (random 20) 15))
(loop-if-not-destructed))
('on-duty
(if (> (slot-ref clerk 'patience) 0)
(tell-room (random-choice clerk-working-impatience-texts))
(slot-set! clerk 'patience (- (slot-ref clerk 'patience)
(+ (random 2) 1)))
- (8sleep (+ (random 60) 40))
+ (daydream (+ (random 60) 40))
(loop-if-not-destructed))
;; Back to slacking
(begin
(tell-room clerk-return-to-slacking-text)
;; annnnnd back to slacking
(slot-set! clerk 'state 'slacking)
- (8sleep (+ (random 30) 15))
+ (daydream (+ (random 30) 15))
(loop-if-not-destructed))))))
#:accessor .state))
(define (hard-drive-act-get-state hard-drive message)
- (<-reply message (.state hard-drive)))
+ (.state hard-drive))
(define* (hard-drive-desc hard-drive #:optional whos-looking)
`((p "The hard drive is labeled \"RL02.5\". It's a little under a meter tall.")
(cond
((ci-member direct-obj '("button" "load button" "load"))
(tell-room-excluding-player
- `(,(mbody-val (<-wait player 'get-name))
+ `(,(<-wait player 'get-name)
" presses the button on the hard disk."))
(<- player 'tell
#:text "You press the button on the hard disk.")
;; I have no idea what this drive did when you didn't have a platter
;; in it and pressed load, but I know there was a FAULT button.
(tell-room "You hear some movement inside the hard drive...")
- (8sleep 1.5)
+ (daydream 1.5)
(tell-room
'("... but then the FAULT button blinks a couple times. "
"What could be missing?")))
((with-disc)
(set! (.state gameobj) 'loading)
(tell-room "The hard disk begins to spin up!")
- (8sleep 2)
+ (daydream 2)
(set! (.state gameobj) 'ready)
(tell-room "The READY light turns on!"))
((loading ready)
(call/ec
(lambda (return)
(for-each (lambda (occupant)
- (define goes-by (mbody-val (<-wait occupant 'goes-by)))
+ (define goes-by (<-wait occupant 'goes-by))
(when (ci-member direct-obj goes-by)
(return occupant)))
- (mbody-val (<-wait player 'get-occupants)))
+ (<-wait player 'get-occupants))
;; nothing found
#f)))
(cond
(<- player 'tell
#:text `("You don't seem to have any such " ,direct-obj " to put "
,preposition " " ,our-name ".")))
- ((not (mbody-val (<-wait this-thing 'get-prop 'hd-platter?)))
+ ((not (<-wait this-thing 'get-prop 'hd-platter?))
(<- player 'tell
#:text `("It wouldn't make sense to put "
- ,(mbody-val (<-wait this-thing 'get-name))
+ ,(<-wait this-thing 'get-name)
" " ,preposition " " ,our-name ".")))
((not (eq? (.state gameobj) 'empty))
(<- player 'tell
#:key direct-obj indir-obj preposition
(player (message-from message)))
(define (hd-state)
- (mbody-val (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state)))
+ (<-wait (dyn-ref gameobj 'computer-room:hard-drive) 'get-state))
(define (tell-room text)
(<-wait (gameobj-loc gameobj) 'tell-room
#:text text))
(cond
((ci-member direct-obj '("program"))
(tell-room-excluding-player
- `(,(mbody-val (<-wait player 'get-name))
+ `(,(<-wait player 'get-name)
" runs the program loaded on the computer..."))
(tell-player "You run the program on the computer...")
(define-actor <floor-panel> (<gameobj>)
;; TODO: Add "open" verb, since obviously people will try that
((open? (lambda (panel message)
- (<-reply message (slot-ref panel 'open))))
+ (slot-ref panel 'open)))
(open-up floor-panel-open-up))
(open #:init-value #f))
#:name "Computer Room"
#:desc (lambda (gameobj whos-looking)
(define panel-open
- (mbody-val (<-wait (dyn-ref gameobj 'computer-room:floor-panel)
- 'open?)))
+ (<-wait (dyn-ref gameobj 'computer-room:floor-panel)
+ 'open?))
`((p "A sizable computer cabinet covers a good portion of the left
wall. It emits a pleasant hum which covers the room like a warm blanket.
Connected to a computer is a large hard drive.")
#:traverse-check
(lambda (exit room whos-exiting)
(define panel-open
- (mbody-val (<-wait (dyn-ref room 'computer-room:floor-panel)
- 'open?)))
+ (<-wait (dyn-ref room 'computer-room:floor-panel)
+ 'open?))
(if panel-open
(values #t "You descend the spiral staircase.")
(values #f '("You'd love to go down, but the only way "
#:to 'hive-entrance)
(make <exit>
#:name "east"
- #:to 'federation-station)))
-
+ #:to 'federation-station)
+ (make <exit>
+ #:name "south"
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #f '("Ooh, if only you could go south and check this out! "
+ "Unfortunately this whole area is sealed off... the proprietor "
+ "probably never got around to fixing it. "
+ "Too bad, it would have had monsters to fight and everything!"))))
+ (make <exit>
+ #:name "southwest"
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #f '("Hm, it's one of those revolving doors that only revolves in "
+ "one direction, and it isn't this one. You guess that while "
+ "this doesn't appear to be an entrance, it probably is an exit."))))))
;; map
('underground-lab:map
<readable> 'underground-lab
('underground-lab:8sync-sign
<readable> 'underground-lab
#:name "a sign labeled \"8sync design goals\""
- #:goes-by '("sign" "8sync design goals sign" "8sync sign")
+ #:goes-by '("sign" "8sync design goals sign" "8sync goals" "8sync design" "8sync sign")
#:read-text 8sync-design-goals
#:desc `((p "The sign says:")
,8sync-design-goals))))
('gift-shop
<room> #f
#:name "Museum Gift Shop"
- #:desc "foo"
+ #:desc '("There are all sorts of scrolls and knicknacks laying around here, "
+ "but they all seem glued in place and instead of a person manning the shop "
+ "there's merely a cardboard cutout of a person with a \"shopkeeper\" nametag. "
+ "You can pretty well bet that someone wanted to finish this room but ran out of "
+ "time.")
#:exits (list
(make <exit>
#:name "northeast"
- #:to 'underground-lab)
+ #:to 'underground-lab
+ #:traverse-check
+ (lambda (exit room whos-exiting)
+ (values #t '("The revolving door spins as you walk through it. Whee!"))))
(make <exit>
#:name "north"
#:to 'async-museum)))))
projects / mudsync.git / blobdiff