mudsync/player.scm \
mudsync/room.scm \
mudsync/run-game.scm \
+ mudsync/receive-star.scm \
mudsync/package-config.scm \
mudsync/utils.scm \
mudsync/contrib/mime-types.scm \
font-family: 'Inconsolata';
font-style: normal;
font-weight: 400;
- src: local('Inconsolata-Regular'), local('Inconsolata'), local('Inconsolata Regular'), url('../fonts/inconsolata/Inconsolata-Regular.ttf');
+ src: url('../fonts/inconsolata/Inconsolata-Regular.ttf');
}
@font-face {
font-family: 'Inconsolata';
font-style: normal;
font-weight: 700;
- src: local('Inconsolata-Bold'), local('Inconsolata Bold'), url('../fonts/inconsolata/Inconsolata-Bold.ttf');
+ src: url('../fonts/inconsolata/Inconsolata-Bold.ttf');
}
*, *:before, *:after {
("texinfo" ,texinfo)))
(inputs `(("guile" ,guile-2.2)
("guile-8sync" ,guile-8sync)
- ("guile-irregex" ,guile2.2-irregex)))
+ ("guile-irregex" ,guile2.2-irregex)
+ ("guile-fibers" ,guile-fibers)))
(arguments
`(#:phases (modify-phases %standard-phases
(add-before 'configure 'bootstrap
#:use-module (8sync)
#:use-module (oop goops)
#:use-module (mudsync gameobj)
+ #:use-module (mudsync receive-star)
#:use-module (mudsync utils)
#:use-module (ice-9 control)
#:export (<container>
#:key direct-obj indir-obj preposition
(player (message-from message)))
(define player-name
- (mbody-val (<-wait player 'get-name)))
+ (<-wait player 'get-name))
(define player-loc
- (mbody-val (<-wait player 'get-loc)))
+ (<-wait player 'get-loc))
(define our-name (slot-ref gameobj 'name))
;; We need to check if we even have such a thing
(define this-thing
(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)))
(gameobj-occupants gameobj))
;; nothing found
#f)))
(define (this-thing-name)
- (mbody-val (<-wait this-thing 'get-name)))
+ (<-wait this-thing 'get-name))
(define (should-take-from-me)
(and this-thing
(slot-ref-maybe-runcheck gameobj 'take-from-me? player this-thing)))
,(this-thing-name) " " ,preposition " " ,our-name "."))
(define (this-thing-objection)
- (mbody-receive (_ taken-ok? #:key why-not) ; does the object object to being removed?
+ (receive* (taken-ok? #:key why-not) ; does the object object to being removed?
(<-wait this-thing 'ok-to-be-taken-from? player) ; @@ no need to supply from where
(and (not taken-ok?)
;; Either give the specified reason, or give a boilerplate one
#:key direct-obj indir-obj preposition
(player (message-from message)))
(define player-name
- (mbody-val (<-wait player 'get-name)))
+ (<-wait player 'get-name))
(define player-loc
- (mbody-val (<-wait player 'get-loc)))
+ (<-wait player 'get-loc))
(define our-name (slot-ref gameobj 'name))
;; We need to check if we even have such a thing
(define this-thing
(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)))
(define (this-thing-name)
- (mbody-val (<-wait this-thing 'get-name)))
+ (<-wait this-thing 'get-name))
(define (should-put-in-me)
(and this-thing
(slot-ref-maybe-runcheck gameobj 'put-in-me? player this-thing)))
`("As much as you'd like to, it doesn't seem like you can put "
,(this-thing-name) " " ,preposition " " ,our-name "."))
(define (this-thing-objection)
- (mbody-receive (_ put-in-ok? #:key why-not) ; does the object object to being moved?
+ (receive* (put-in-ok? #:key why-not) ; does the object object to being moved?
(<-wait this-thing 'ok-to-be-put-in? player (actor-id gameobj))
(and (not put-in-ok?)
;; Either give the specified reason, or give a boilerplate one
((symbol class loc args ...)
;; initialize the special object
(let ((special-obj
- (apply create-actor* gm class
+ (apply create-actor* class
;; set cookie to be the object's symbol
(symbol->string symbol)
#:gm (actor-id gm)
(define (gm-setup-network gm)
;; Create a default network manager if none available
(slot-set! gm 'network-manager
- (create-actor* gm <network-manager> "netman"
- #:send-input-to (actor-id gm)))
+ (create-actor* <network-manager> "netman"
+ #:send-input-to (actor-id gm)))
;; TODO: Add host and port options
(<-wait (gm-network-manager gm) 'start-listening))
#:input data))
(define* (gm-lookup-special actor message #:key symbol)
- (<-reply message (hash-ref (slot-ref actor 'special-dir) symbol)))
+ (hash-ref (slot-ref actor 'special-dir) symbol))
(define* (gm-write-home actor message #:key text)
(define client-id (hash-ref (gm-reverse-client-dir actor)
(((? (cut eq? <> special-symbol) symbol) class loc args ...)
;; initialize the special object
(let ((special-obj
- (apply create-actor* gm class
+ (apply create-actor* class
;; set cookie to be the object's symbol
(symbol->string symbol)
#:gm (actor-id gm)
(hash-ref (gm-special-dir gm) default-room))
;; create and register the player
(player
- (create-actor*
gm (@@ (mudsync player) <player>) "player"
+ (create-actor* (@@ (mudsync player) <player>) "player"
#:name guest-name
#:gm (actor-id gm)
#:client client-id)))
(define-module (mudsync gameobj)
#:use-module (mudsync command)
#:use-module (mudsync utils)
+ #:use-module (mudsync receive-star)
#:use-module (8sync actors)
#:use-module (8sync agenda)
#:use-module (8sync rmeta-slot)
(tell gameobj-tell-no-op)
(assist-replace gameobj-act-assist-replace)
(ok-to-drop-here? (lambda (gameobj message . _)
- (<-reply message #t))) ; ok to drop by default
+ #t)) ; ok to drop by default
(ok-to-be-taken-from? gameobj-ok-to-be-taken-from)
(ok-to-be-put-in? gameobj-ok-to-be-put-in)
(define (create-gameobj class gm loc . args)
"Create a gameobj of CLASS with GM and set to location LOC, applying rest of ARGS.
Note that this doesn't do any special dyn-ref of the location."
- (let ((new-gameobj (apply create-actor (%current-actor) class
+ (let ((new-gameobj (apply create-actor class
#:gm gm args)))
;; Set the location
(<-wait new-gameobj 'set-loc! #:loc loc)
;; Kind of a useful utility, maybe?
(define (simple-slot-getter slot)
(lambda (actor message)
- (<-reply message (slot-ref actor slot))))
+ (slot-ref actor slot)))
(define (gameobj-replace-step-occupants actor occupants)
;; Snarf all the occupants!
(define (run-replacement actor replaces replace-steps)
(when replaces
- (mbody-receive (_ #:key occupants)
- (<-wait replaces 'assist-replace)
- (for-each
- (lambda (replace-step)
- (replace-step actor occupants))
- replace-steps))))
+ (call-with-values
+ (lambda ()
+ (<-wait replaces 'assist-replace))
+ (lambda* (#:key occupants)
+ (for-each
+ (lambda (replace-step)
+ (replace-step actor occupants))
+ replace-steps)))))
(define %nothing (cons '*the* '*nothing*))
(define (gameobj-setup-props gameobj)
(hashq-set! (slot-ref gameobj 'props) key val))
(define* (gameobj-act-get-prop actor message key #:optional dflt)
- (<-reply message (gameobj-get-prop actor key dflt)))
+ (gameobj-get-prop actor key dflt))
(define (gameobj-goes-by gameobj)
"Find the name we go by. Defaults to #:name if nothing else provided."
(define (gameobj-act-goes-by actor message)
"Reply to a message requesting what we go by."
- (<-reply message (gameobj-goes-by actor)))
+ (gameobj-goes-by actor))
(define (val-or-run val-or-proc)
"Evaluate if a procedure, or just return otherwise"
"Get commands a co-occupant of the room might execute for VERB"
(define candidate-commands
(get-candidate-commands actor 'commands verb))
- (<-reply message
- #:commands candidate-commands
- #:goes-by (gameobj-goes-by actor)))
+ (values #:commands candidate-commands
+ #:goes-by (gameobj-goes-by actor)))
(define* (gameobj-get-container-dom-commands actor message #:key verb)
"Get (dominant) commands as the container / room of message's sender"
(define candidate-commands
(get-candidate-commands actor 'container-dom-commands verb))
- (<-reply message #:commands candidate-commands))
+ (values #:commands candidate-commands))
(define* (gameobj-get-container-sub-commands actor message #:key verb)
"Get (subordinate) commands as the container / room of message's sender"
(define candidate-commands
(get-candidate-commands actor 'container-sub-commands verb))
- (<-reply message #:commands candidate-commands))
+ (values #:commands candidate-commands))
(define* (gameobj-get-contained-commands actor message #:key verb)
"Get commands as being contained (eg inventory) of commanding gameobj"
(define candidate-commands
(get-candidate-commands actor 'contained-commands verb))
- (<-reply message
- #:commands candidate-commands
- #:goes-by (gameobj-goes-by actor)))
+ (values #:commands candidate-commands
+ #:goes-by (gameobj-goes-by actor)))
(define* (gameobj-add-occupant! actor message #:key who)
"Add an actor to our list of present occupants"
(define* (gameobj-get-occupants actor message #:key exclude)
"Get all present occupants of the room."
- (define occupants
- (gameobj-occupants actor #:exclude exclude))
- (<-reply message occupants))
+ (gameobj-occupants actor #:exclude exclude))
(define (gameobj-act-get-loc actor message)
- (<-reply message (slot-ref actor 'loc)))
+ (slot-ref actor 'loc))
(define (gameobj-set-loc! gameobj loc)
"Set the location of this object."
(define* (gameobj-get-desc actor message #:key whos-looking)
"This is the action equivalent of the gameobj-desc getter"
- (<-reply message (gameobj-desc actor #:whos-looking whos-looking)))
+ (gameobj-desc actor #:whos-looking whos-looking))
(define (gameobj-visible-to-player? gameobj whos-looking)
"Check to see whether we're visible to the player or not.
name)
(#f #f))
#f))
- (<-reply message #:text name-to-return))
+ (values #:text name-to-return))
(define (gameobj-self-destruct gameobj)
"General gameobj self destruction routine"
;; But that's life in a live hacked game!
(define (gameobj-act-assist-replace gameobj message)
"Vanilla method for assisting in self-replacement for live hacking"
- (apply <-reply message
- (gameobj-replace-data* gameobj)))
+ (apply values (gameobj-replace-data* gameobj)))
(define (gameobj-ok-to-be-taken-from gameobj message whos-acting)
(call-with-values (lambda ()
(slot-ref-maybe-runcheck gameobj 'take-me?
whos-acting #:from #t))
;; This allows this to reply with #:why-not if appropriate
- (lambda args
- (apply <-reply message args))))
+ (lambda args args)))
(define (gameobj-ok-to-be-put-in gameobj message whos-acting where)
(call-with-values (lambda ()
(slot-ref-maybe-runcheck gameobj 'drop-me?
whos-acting where))
;; This allows this to reply with #:why-not if appropriate
- (lambda args
- (apply <-reply message args))))
+ (lambda args args)))
\f
;;; Utilities every gameobj has
((? symbol? _)
;; TODO: If we get back an #f at this point, should we throw
;; an error? Obviously #f is okay, but maybe not if
- (mbody-val (<-wait (slot-ref gameobj 'gm) 'lookup-special
- #:symbol special-symbol)))
+ (<-wait (slot-ref gameobj 'gm) 'lookup-special
+ #:symbol special-symbol))
;; if it's false, return nothing
(#f #f)
;; otherwise it's probably an address, return it as-is
#:key direct-obj
(player (message-from message)))
(define player-name
- (mbody-val (<-wait player 'get-name)))
+ (<-wait player 'get-name))
(define player-loc
- (mbody-val (<-wait player 'get-loc)))
+ (<-wait player 'get-loc))
(define our-name (slot-ref gameobj 'name))
(define self-should-take
(slot-ref-maybe-runcheck gameobj 'take-me? player))
#:key direct-obj
(player (message-from message)))
(define player-name
- (mbody-val (<-wait player 'get-name)))
+ (<-wait player 'get-name))
(define player-loc
- (mbody-val (<-wait player 'get-loc)))
+ (<-wait player 'get-loc))
(define our-name (slot-ref gameobj 'name))
(define should-drop
(slot-ref-maybe-runcheck gameobj 'drop-me? player))
(define (room-objection-to-drop)
- (mbody-receive (_ drop-ok? #:key why-not) ; does the room object to dropping?
+
+ (receive* (drop-ok? #:key why-not) ; does the room object to dropping?
(<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj))
(and (not drop-ok?)
;; Either give the specified reason, or give a boilerplate one
(web-server-port %default-web-server-port))
(if web-server-port
(nm-install-web-server actor server web-server-port))
- (nm-install-socket actor server port)))
+ ;; (nm-install-socket actor server port)
+ ))
(send-to-client nm-send-to-client-id)
(new-socket-client nm-new-socket-client)
(new-web-client nm-new-web-client)
(hash-set! (nm-clients nm) client-id
(cons 'websocket ws-client-id))
(<- (nm-send-input-to nm) 'new-client #:client client-id)
- (<-reply message client-id))
+ client-id)
(define (nm-client-receive-loop nm client-socket client-id)
"Make a method to receive client data"
"Handle a closed port"
(format #t "DEBUG: handled closed port ~a\n" client-id)
(hash-remove! (nm-clients nm) client-id)
- (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed #:client client-id))
+ (<- (nm-send-input-to nm) 'client-closed #:client client-id))
(define (nm-handle-line nm client-id line)
"Handle an incoming line of input from a client"
- (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-input
+ (<- (nm-send-input-to nm) 'client-input
#:data line
#:client client-id))
(define (nm-install-web-server nm server web-server-port)
"This installs the web server, which we see in use below...."
(set! (.web-server nm)
- (create-actor nm <mudsync-ws-server>
+ (create-actor <mudsync-ws-server>
#:network-manager (actor-id nm)
#:port web-server-port
#:http-handler (wrap-apply http-handler)
(define (websocket-client-connect websocket-server client-id)
(let ((nm-client-id
- (mbody-val (<-wait (.network-manager websocket-server)
- 'new-web-client client-id))))
+ (<-wait (.network-manager websocket-server)
+ 'new-web-client client-id)))
(hash-set! (.nm-client-ids websocket-server)
client-id nm-client-id)))
(or (getenv "MUDSYNC_DATADIR")
"/usr/local/share/mudsync"))
-(define (clean-path path)
- "Remove any nasty .. stuff from the path"
- (string-join (delete ".." (string-split path file-name-separator-char))
- file-name-separator-string))
-
(define (scope-datadir filename)
- (clean-path (string-append %datadir filename)))
+ (string-append %datadir filename))
(define (web-static-filepath filename)
(scope-datadir (string-append "/web-static" filename)))
#:use-module (mudsync gameobj)
#:use-module (mudsync game-master)
#:use-module (mudsync parser)
+ #:use-module (mudsync receive-star)
#:use-module (8sync actors)
#:use-module (8sync agenda)
#:use-module (8sync rmeta-slot)
(define inv-names
(map
(lambda (inv-item)
- (mbody-val (<-wait inv-item 'get-name)))
+ (<-wait inv-item 'get-name))
(gameobj-occupants player)))
(define text-to-show
(if (eq? inv-names '())
;; Ask the room for its commands
(define room-dom-commands
;; TODO: Map room id and sort
- (mbody-receive (_ #:key commands)
+ (receive* (#:key commands)
(<-wait player-loc 'get-container-dom-commands
#:verb verb)
commands))
(define room-sub-commands
;; TODO: Map room id and sort
- (mbody-receive (_ #:key commands)
+ (receive* (#:key commands)
(<-wait player-loc 'get-container-sub-commands
#:verb verb)
commands))
(define co-occupants
(remove
(lambda (x) (equal? x (actor-id player)))
- (mbody-val (<-wait player-loc 'get-occupants))))
+ (<-wait player-loc 'get-occupants)))
;; @@: There's a race condition here if someone leaves the room
;; during this, heh...
(define co-occupant-commands
(fold
(lambda (co-occupant prev)
- (mbody-receive (_ #:key commands goes-by)
+ (receive* (#:key commands goes-by)
(<-wait co-occupant 'get-commands
#:verb verb)
(append
(define inv-item-commands
(fold
(lambda (inv-item prev)
- (mbody-receive (_ #:key commands goes-by)
+ (receive* (#:key commands goes-by)
(<-wait inv-item 'get-contained-commands
#:verb verb)
(append
--- /dev/null
+;;; Mudsync --- Live hackable MUD
+;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; This file is part of Mudsync.
+;;;
+;;; Mudsync is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Mudsync is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mudsync. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mudsync receive-star)
+ #:export (receive*))
+
+(define-syntax-rule (receive* formals expr body ...)
+ (call-with-values
+ (lambda ()
+ expr)
+ (lambda* formals
+ body ...)))
#f))
(define player (message-from message))
(define player-name
- (mbody-val (<-wait player 'get-name)))
+ (<-wait player 'get-name))
(cond
(exit
(call-with-values (lambda ()
(define occupant-names-all
(map
(lambda (occupant)
- (call-with-message (<-wait occupant 'visible-name
- #:whos-looking player-id)
- (lambda* (_ #:key text)
- text)))
+ (call-with-values
+ (lambda ()
+ (<-wait occupant 'visible-name
+ #:whos-looking player-id))
+ (lambda* (#:key text)
+ text)))
(remove
(lambda (x) (equal? x player-id))
(hash-map->list (lambda (x _) x)
(lambda (return)
(for-each
(lambda (occupant)
- (define goes-by (mbody-val (<-wait occupant 'goes-by)))
+ (define goes-by (<-wait occupant 'goes-by))
(if (ci-member called-this goes-by)
(return occupant)))
(hash-map->list (lambda (key val) key)
(define* (room-cmd-say room message #:key phrase)
"Command: Say something to room participants."
(define player-name
- (mbody-val (<-wait (message-from message) 'get-name)))
+ (<-wait (message-from message) 'get-name))
(define message-to-send
`((b "<" ,player-name ">") " " ,phrase))
(room-tell-room room message-to-send))
(define* (room-cmd-emote room message #:key phrase)
"Command: Say something to room participants."
(define player-name
- (mbody-val (<-wait (message-from message) 'get-name)))
+ (<-wait (message-from message) 'get-name))
(define message-to-send
`((b "* " ,player-name) " " ,phrase))
(room-tell-room room message-to-send))
(define* (room-announce-entrance room message #:key who-entered)
(define player-name
- (mbody-val (<-wait who-entered 'get-name)))
+ (<-wait who-entered 'get-name))
(define message-to-send
(format #f "~a enters the room.\n" player-name))
(room-tell-room room message-to-send
#:use-module (mudsync game-master)
#:use-module (8sync)
#:use-module (8sync repl)
- #:use-module (8sync debug)
+ #:use-module (fibers conditions)
+ ;; #:use-module (8sync debug)
#:use-module (srfi srfi-1)
#:use-module (ice-9 receive)
#:use-module (ice-9 q)
;;; ==================
(define* (run-demo game-spec default-room #:key repl-server)
- (define hive (make-hive))
- (define new-conn-handler
- (make-default-room-conn-handler default-room))
- (define gm
- (bootstrap-actor-gimmie* hive <game-master> "gm"
- #:new-conn-handler new-conn-handler))
- (define injector
- (bootstrap-actor hive <gameobj-injector>
- #:gm (actor-id gm)))
+ (run-hive
+ (lambda (hive)
+ (define new-conn-handler
+ (make-default-room-conn-handler default-room))
+ (define gm
+ ;; (bootstrap-actor-gimmie* hive <game-master> "gm"
+ ;; #:new-conn-handler new-conn-handler)
+ (create-actor* <game-master> "gm"
+ #:new-conn-handler new-conn-handler))
+ (define injector
+ (create-actor <gameobj-injector>
+ #:gm gm))
- (define repl-manager
- (bootstrap-actor* hive <repl-manager> "repl"
+ (define repl-manager
+ (create-actor* <repl-manager> "repl"
#:subscribers (list injector)))
- (set! %live-gm gm)
- (set! %live-hive hive)
+ ;; (set! %live-gm gm)
+ (set! %live-hive hive)
- (set! %inject-queue (make-q))
+ (set! %inject-queue (make-q))
- (run-hive hive
- (list (bootstrap-message hive (actor-id gm) 'init-world
- #:game-spec game-spec))))
+ (<- gm 'init-world
+ #:game-spec game-spec)
+ ;; (run-hive hive
+ ;; (list (bootstrap-message hive (actor-id gm) 'init-world
+ ;; #:game-spec game-spec)))
+ (wait (make-condition)))
+ ;; Just for testing / for now...
+ #:parallelism 1))
(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))
(<-wait player 'tell
#:text '("You start the rube goldberg machine."))
(<-wait (gameobj-loc rgb-machine) 'tell-room
- #:text `(,(mbody-val (<-wait player 'get-name))
+ #:text `(,(<-wait player 'get-name)
" runs the rube goldberg machine.")
#:exclude player)
- (8sleep 1)
+ (daydream 1)
(match (.rgb-items rgb-machine)
((first-item rest ...)
(<- (dyn-ref rgb-machine first-item) 'trigger))))
(<-wait player 'tell
#:text '("You reset the rube goldberg machine."))
(<-wait (gameobj-loc rgb-machine) 'tell-room
- #:text `(,(mbody-val (<-wait player 'get-name))
+ #: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."))
- (8sleep (/ 1 2))
+ (daydream (/ 1 2))
(for-each
(lambda (rgb-item)
(<- (dyn-ref rgb-machine rgb-item) 'reset)
- (8sleep (/ 1 2)))
+ (daydream (/ 1 2)))
(.rgb-items rgb-machine))
(<- (gameobj-loc rgb-machine) 'tell-room
#:text "The machine's mechanical arm retreats into the wall!")
(<- room 'tell-room #:text str))
;; A number? Sleep for that many secs
((? number? num)
- (8sleep num))
+ (daydream num))
;; A symbol? That's another gameobj to look up dynamically
((? symbol? sym)
(<- (dyn-ref rgb-item sym) 'trigger
(<- room 'tell-room
#:text '((i "*kshhhhhh!*")
" The water has boiled!"))
- (8sleep .25)
+ (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)
(define (hot-tea-cmd-drink hot-tea message . _)
(define player (message-from message))
- (define player-loc (mbody-val (<-wait player 'get-loc)))
- (define player-name (mbody-val (<-wait player 'get-name)))
+ (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
(define (hot-tea-cmd-sip hot-tea message . _)
(define player (message-from message))
- (define player-loc (mbody-val (<-wait player 'get-loc)))
- (define player-name (mbody-val (<-wait player 'get-name)))
+ (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!")
,(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)
,(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)))))))))
;; Things inside the toy chest
(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 "
projects / mudsync.git / commitdiff