Unless necessary, in which case use <-*.
(match-lambda
((special-obj . loc)
(if loc
- (<-wait gm special-obj 'set-loc!
+ (<-wait special-obj 'set-loc!
#:loc (hash-ref (gm-special-dir gm) loc)))))
set-locs)
(for-each
(lambda (special-obj)
(format #t "Initializing ~s...\n" (address->string special-obj))
- (<-wait gm special-obj 'init))
+ (<-wait special-obj 'init))
specials))
#:send-input-to (actor-id gm)))
;; TODO: Add host and port options
- (<-wait gm (gm-network-manager gm) 'start-listening))
+ (<-wait (gm-network-manager gm) 'start-listening))
(define (gm-setup-database gm)
'TODO)
;; debugging
(format #t "DEBUG: From ~s: ~s\n" client data)
- (<- actor player 'handle-input
+ (<- player 'handle-input
#:input data))
(define* (gm-lookup-special actor message #:key symbol)
- (<-reply actor message (hash-ref (slot-ref actor 'special-dir) symbol)))
+ (<-reply message (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)
(message-from message)))
- (<- actor (gm-network-manager actor) 'send-to-client
+ (<- (gm-network-manager actor) 'send-to-client
#:client client-id
#:data text))
;; room, if we have one.
;; (In some games, if the user never connected)
(when actor-id
- (<-wait gm actor-id 'disconnect-self-destruct)
+ (<-wait actor-id 'disconnect-self-destruct)
;; Unregister from the client directories.
(gm-unregister-client! gm client)))
#:gm (actor-id gm)
args)))
;; Set the location
- (<-wait gm special-obj 'set-loc!
- #:loc (hash-ref (gm-special-dir gm) loc))
+ (<-wait special-obj 'set-loc!
+ #:loc (hash-ref (gm-special-dir gm) loc))
;; Initialize the object, and depending on if an object
;; already exists with this info, ask it to coordinate
;; replacing with the existing object.
(if existing-obj
- (<-wait gm special-obj 'init #:replace existing-obj)
- (<-wait gm special-obj 'init))
+ (<-wait special-obj 'init #:replace existing-obj)
+ (<-wait special-obj 'init))
;; Register the object
(hash-set! (gm-special-dir gm) symbol special-obj)
;; Destroy the original, if it exists.
(if existing-obj
- (<- gm existing-obj 'self-destruct #:why 'replaced))))))
+ (<- existing-obj 'self-destruct #:why 'replaced))))))
;;; GM utilities
(hash-remove! (gm-reverse-client-dir gm) client-id)
;; Destroy player
(if destroy-player
- (<- gm player-id 'self-destruct)))
+ (<- player-id 'self-destruct)))
(#f (throw 'no-client-to-unregister
"Can't unregister a client that doesn't exist?"
client-id))))
;; Register the player in our database of players -> connections
(gm-register-client! gm client-id player)
;; Dump the player into the default room
- (<-wait gm player 'set-loc! #:loc room-id)
+ (<-wait player 'set-loc! #:loc room-id)
;; Initialize the player
- (<-wait gm player 'init)
- (<- gm room-id 'tell-room
+ (<-wait player 'init)
+ (<- room-id 'tell-room
#:text (format #f "You see ~a materialize out of thin air!\n"
guest-name)
#:exclude player)))))
;; Kind of a useful utility, maybe?
(define (simple-slot-getter slot)
(lambda (actor message)
- (<-reply actor message (slot-ref actor slot))))
+ (<-reply message (slot-ref actor slot))))
(define (gameobj-replace-step-occupants actor occupants)
;; Snarf all the occupants!
(when occupants
(for-each
(lambda (occupant)
- (<-wait actor occupant 'set-loc!
+ (<-wait occupant 'set-loc!
#:loc (actor-id actor)))
occupants)))
(define (run-replacement actor replaces replace-steps)
(when replaces
(msg-receive (_ #:key occupants)
- (<-wait actor replaces 'assist-replace)
+ (<-wait replaces 'assist-replace)
(for-each
(lambda (replace-step)
(replace-step actor occupants))
(define (gameobj-act-goes-by actor message)
"Reply to a message requesting what we go by."
- (<-reply actor message
- #:goes-by (gameobj-goes-by actor)))
+ (<-reply message #:goes-by (gameobj-goes-by actor)))
(define (val-or-run val-or-proc)
"Evaluate if a procedure, or just return otherwise"
(define filtered-commands
(filter-commands (val-or-run (slot-ref actor 'commands))
verb))
- (<-reply actor message
+ (<-reply message
#:commands filtered-commands
#:goes-by (gameobj-goes-by actor)))
(define filtered-commands
(filter-commands (val-or-run (slot-ref actor 'container-commands))
verb))
- (<-reply actor message #:commands filtered-commands))
+ (<-reply message #:commands filtered-commands))
(define* (gameobj-get-contained-commands actor message #:key verb)
"Get commands as being contained (eg inventory) of commanding gameobj"
(define filtered-commands
(filter-commands (val-or-run (slot-ref actor 'contained-commands))
verb))
- (<-reply actor message
+ (<-reply message
#:commands filtered-commands
#:goes-by (gameobj-goes-by actor)))
(define occupants
(gameobj-occupants actor #:exclude exclude))
- (<-reply actor message
- #:occupants occupants))
+ (<-reply message #:occupants occupants))
(define (gameobj-act-get-loc actor message)
- (<-reply actor message (slot-ref actor 'loc)))
+ (<-reply message (slot-ref actor 'loc)))
(define (gameobj-set-loc! gameobj loc)
"Set the location of this object."
(slot-set! gameobj 'loc loc)
;; Change registation of where we currently are
(if old-loc
- (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj)))
+ (<-wait old-loc 'remove-occupant! #:who (actor-id gameobj)))
(if loc
- (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))))
+ (<-wait loc 'add-occupant! #:who (actor-id gameobj)))))
;; @@: Should it really be #:id ? Maybe #:loc-id or #:loc?
(define* (gameobj-act-set-loc! actor message #:key loc)
((? procedure? desc-proc)
(desc-proc actor whos-looking))
(desc desc)))
- (<-reply actor message desc-text))
+ (<-reply message desc-text))
(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 actor message #:text name-to-return))
+ (<-reply message #: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 actor message)
"Vanilla method for assisting in self-replacement for live hacking"
- (apply <-reply actor message
+ (apply <-reply message
(gameobj-replace-data* actor)))
\f
(match special-symbol
;; if it's a symbol, look it up dynamically
((? symbol? _)
- (msg-val (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special
+ (msg-val (<-wait (slot-ref gameobj 'gm) 'lookup-special
#:symbol special-symbol)))
;; if it's false, return nothing
(#f #f)
(sockaddr:addr client-details)))
(fcntl client F_SETFL (logior O_NONBLOCK (fcntl client F_GETFL)))
(hash-set! (nm-clients nm) client-id client)
- (<- nm (nm-send-input-to nm) 'new-client #:client client-id)
+ (<-* `(#:actor ,nm) (nm-send-input-to nm) 'new-client #:client client-id)
(nm-client-receive-loop nm client client-id))
(define (nm-client-receive-loop nm client client-id)
(begin
(nm-handle-line nm client client-id
(string-trim-right line #\return))
- (when (actor-am-i-alive? nm)
+ (when (actor-alive? nm)
(loop)))))
(loop))
"Handle a closed port"
(format #t "DEBUG: handled closed port ~x\n" client-id)
(hash-remove! (nm-clients nm) client-id)
- (<- nm (nm-send-input-to nm) 'client-closed #:client client-id))
+ (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed #:client client-id))
(define-method (nm-handle-port-eof nm client client-id)
"Handle seeing an EOF on port"
(format #t "DEBUG: handled eof-object on port ~x\n" client-id)
(close client)
(hash-remove! (nm-clients nm) client-id)
- (<- nm (nm-send-input-to nm) 'client-closed #:client client-id))
+ (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed
+ #:client client-id))
(define-method (nm-handle-line nm client client-id line)
"Handle an incoming line of input from a client"
- (<- nm (nm-send-input-to nm) 'client-input
+ (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-input
#:data line
#:client client-id))
(define (player-init player message)
;; Look around the room we're in
- (<- player (gameobj-loc player) 'look-room))
+ (<- (gameobj-loc player) 'look-room))
(define* (player-handle-input player message #:key input)
(match winner
((cmd-action winner-id message-args)
- (apply <- player winner-id cmd-action message-args))
+ (apply <- winner-id cmd-action message-args))
(#f
- (<- player (gameobj-gm player) 'write-home
+ (<- (gameobj-gm player) 'write-home
#:text "Huh?\n"))))
(define* (player-tell player message #:key text)
- (<- player (gameobj-gm player) 'write-home
+ (<- (gameobj-gm player) 'write-home
#:text text))
(define (player-disconnect-self-destruct player message)
"Action routine for being told to disconnect and self destruct."
(define loc (gameobj-loc player))
(when loc
- (<- player loc 'tell-room
+ (<- loc 'tell-room
#:exclude (actor-id player)
#:text (format #f "~a disappears in a puff of entropy!\n"
(slot-ref player 'name))))
(define inv-names
(map
(lambda (inv-item)
- (msg-val (<-wait player inv-item 'get-name)))
+ (msg-val (<-wait inv-item 'get-name)))
(gameobj-occupants player)))
(define text-to-show
(if (eq? inv-names '())
(map (lambda (item-name)
(string-append " * " item-name "\n"))
inv-names))))
- (<- player (actor-id player) 'tell #:text text-to-show))
+ (<- (actor-id player) 'tell #:text text-to-show))
;;; Command handling
(define room-commands
;; TODO: Map room id and sort
(msg-receive (_ #:key commands)
- (<-wait player player-loc
- 'get-container-commands
- #:verb verb)
+ (<-wait player-loc 'get-container-commands
+ #:verb verb)
commands))
;; All the co-occupants of the room (not including ourself)
(remove
(lambda (x) (equal? x (actor-id player)))
(msg-receive (_ #:key occupants)
- (<-wait player player-loc 'get-occupants)
+ (<-wait player-loc 'get-occupants)
occupants)))
;; @@: There's a race condition here if someone leaves the room
(fold
(lambda (co-occupant prev)
(msg-receive (_ #:key commands goes-by)
- (<-wait player co-occupant 'get-commands
- #:verb verb)
+ (<-wait co-occupant 'get-commands
+ #:verb verb)
(append
(map (lambda (command)
(list command goes-by co-occupant))
(fold
(lambda (inv-item prev)
(msg-receive (_ #:key commands goes-by)
- (<-wait player inv-item
- 'get-contained-commands
+ (<-wait inv-item 'get-contained-commands
#:verb verb)
(append
(map (lambda (command)
(dyn-ref room (slot-ref exit 'to))
#f))
(define player-name
- (msg-val (<-wait room (message-from message) 'get-name)))
+ (msg-val (<-wait (message-from message) 'get-name)))
(cond
(exit
;; Set the player's new location
- (<-wait room (message-from message) 'set-loc!
+ (<-wait (message-from message) 'set-loc!
#:loc to-address)
;; Tell everyone else the person walked away
(room-tell-room
room
(format #f "~a wanders ~a.\n"
player-name direct-obj))
- (<- room to-address 'announce-entrance
+ (<- to-address 'announce-entrance
#:who-entered (message-from message))
;; Have the new room update the player to the new location
- (<- room to-address 'look-room
+ (<- to-address 'look-room
#:to-id (message-from message)))
(else
- (<- room (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "You don't see any way to go there.\n"))))
(define (room-cmd-go-where room message)
- (<- room (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "Go where?\n"))
;;; look commands
(define occupant-names-all
(map
(lambda (occupant)
- (call-with-message (<-wait room occupant 'visible-name
+ (call-with-message (<-wait occupant 'visible-name
#:whos-looking player-id)
(lambda* (_ #:key text)
text)))
(string-append room-text occupant-names-string)
room-text))
- (<- room player-id 'tell
+ (<- player-id 'tell
#:text final-text))
(for-each
(lambda (occupant)
(msg-receive (_ #:key goes-by)
- (<-wait room occupant 'goes-by)
+ (<-wait occupant 'goes-by)
(if (member called-this goes-by)
(return occupant))))
(hash-map->list (lambda (key val) key)
(cond
(matching-object
(let ((obj-desc
- (msg-val (<-wait room matching-object 'get-desc
+ (msg-val (<-wait matching-object 'get-desc
#:whos-looking (message-from message)))))
(if obj-desc
- (<- room (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text (string-append obj-desc "\n"))
- (<- room (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text (string-append %formless-desc "\n")))))
(else
- (<- room (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "You don't see that here, so you can't look at it.\n"))))
(if wait
<-wait
<-))
- (deliver-method room tell-me 'tell
+ (deliver-method tell-me 'tell
#:text text))
who-to-tell))
(define* (room-cmd-say room message #:key phrase)
"Command: Say something to room participants."
(define player-name
- (msg-val (<-wait room (message-from message)
- 'get-name)))
+ (msg-val (<-wait (message-from message) 'get-name)))
(define message-to-send
(format #f "~a says: ~a\n" 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
- (msg-val (<-wait room (message-from message)
- 'get-name)))
+ (msg-val (<-wait (message-from message) 'get-name)))
(define message-to-send
(format #f "* ~a ~a\n" player-name phrase))
(room-tell-room room message-to-send))
(define* (room-announce-entrance room message #:key who-entered)
(define player-name
- (msg-val (<-wait room who-entered 'get-name)))
+ (msg-val (<-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
(define* (thing-cmd-take thing message #:key direct-obj)
(define player (message-from message))
(define player-name
- (msg-val (<-wait thing player 'get-name)))
+ (msg-val (<-wait player 'get-name)))
(define player-loc
- (msg-val (<-wait thing player 'get-loc)))
+ (msg-val (<-wait player 'get-loc)))
(define thing-name (slot-ref thing 'name))
(define should-take
(slot-ref-maybe-runcheck thing 'takeable player))
;; Set the location to whoever's picking us up
(begin
(gameobj-set-loc! thing player)
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "You pick up ~a.\n"
thing-name))
- (<- thing player-loc 'tell-room
+ (<- player-loc 'tell-room
#:text (format #f "~a picks up ~a.\n"
player-name
thing-name)
#:exclude player))
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "It doesn't seem like you can pick up ~a.\n"
thing-name))))
(define* (thing-cmd-drop thing message #:key direct-obj)
(define player (message-from message))
(define player-name
- (msg-val (<-wait thing player 'get-name)))
+ (msg-val (<-wait player 'get-name)))
(define player-loc
- (msg-val (<-wait thing player 'get-loc)))
+ (msg-val (<-wait player 'get-loc)))
(define thing-name (slot-ref thing 'name))
(define should-drop
(slot-ref-maybe-runcheck thing 'dropable player))
;; Set the location to whoever's picking us up's location
(begin
(gameobj-set-loc! thing player-loc)
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "You drop ~a.\n"
thing-name))
- (<- thing player-loc 'tell-room
+ (<- player-loc 'tell-room
#:text (format #f "~a drops ~a.\n"
player-name
thing-name)
#:exclude player))
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "It doesn't seem like you can drop ~a.\n"
thing-name))))
(cmd-read readable-cmd-read))))
(define (readable-cmd-read actor message)
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text (string-append (slot-ref actor 'read-text) "\n")))
(format #f "~a says: \"~a\"\n"
(slot-ref actor 'name)
(random-choice (slot-ref actor 'catchphrases))))
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text text-to-send))
(define chat-commands
(define* (sign-cmd-sign-in actor message
#:key direct-obj indir-obj preposition)
(define old-name
- (msg-val (<-wait actor (message-from message) 'get-name)))
+ (msg-val (<-wait (message-from message) 'get-name)))
(define name indir-obj)
(if (valid-name? indir-obj)
(begin
- (<-wait actor (message-from message) 'set-name! name)
- (<- actor (slot-ref actor 'loc) 'tell-room
+ (<-wait (message-from message) 'set-name! name)
+ (<- (slot-ref actor 'loc) 'tell-room
#:text (format #f "~a signs the form!\n~a is now known as ~a\n"
old-name old-name name)))
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "Sorry, that's not a valid name.
Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic
character.\n")))
;; handler... meanwhile, this procedure suspends until we get
;; their response.
(define who-rang
- (msg-val (<-wait bell (message-from message) 'get-name)))
+ (msg-val (<-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.
;; This one just uses <- instead of <-wait, since we don't
;; care when it's delivered; we're not following up on it.
- (<- bell (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "*ring ring!* You ring the bell!\n")
;; We also want everyone else in the room to "hear" the bell,
;; but they get a different message since they aren't the ones
;; name as extracted and assigned to the who-rang variable.
;; Notice how we send this message to our "location", which
;; forwards it to the rest of the occupants in the room.
- (<- bell (gameobj-loc bell) 'tell-room
+ (<- (gameobj-loc bell) 'tell-room
#:text
(format #f "*ring ring!* ~a rings the bell!\n"
who-rang)
;; Now we perform the primary task of the bell, which is to summon
;; the "clerk" character to the room. (This is configurable,
;; so we dynamically look up their address.)
- (<- bell (dyn-ref bell (slot-ref bell 'summons)) 'be-summoned
+ (<- (dyn-ref bell (slot-ref bell 'summons)) 'be-summoned
#:who-summoned (message-from message)))
(define* (furniture-cmd-sit actor message #:key direct-obj)
(define player-name
- (msg-val (<-wait actor (message-from message) 'get-name)))
- (<- actor (message-from message) 'tell
+ (msg-val (<-wait (message-from message) 'get-name)))
+ (<- (message-from message) 'tell
#:text (format #f "You ~a ~a.\n"
(slot-ref actor 'sit-phrase)
(slot-ref actor 'sit-name)))
- (<- actor (slot-ref actor 'loc) 'tell-room
+ (<- (slot-ref actor 'loc) 'tell-room
#:text (format #f "~a ~a on ~a.\n"
player-name
(slot-ref actor 'sit-phrase-third-person)
;; call the gameobj main init method
(gameobj-act-init clerk message)
;; start our main loop
- (<- clerk (actor-id clerk) 'update-loop))
+ (<- (actor-id clerk) 'update-loop))
(define clerk-help-topics
'(("changing name" .
(define* (clerk-cmd-chat clerk message #:key direct-obj)
(match (slot-ref clerk 'state)
('on-duty
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text clerk-general-helpful-line))
('slacking
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text
(string-append
"The clerk says, \""
"\"\n")))))
(define (clerk-cmd-ask-incomplete clerk message)
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "The clerk says, \"Ask about what?\"\n"))
(define clerk-doesnt-know-text
('on-duty
(match (assoc (pk 'indir indir-obj) clerk-help-topics)
((_ . info)
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text
(string-append "The clerk clears her throat and says:\n \""
info
"\"\n")))
(#f
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text clerk-doesnt-know-text))))
('slacking
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "The clerk says, \"Sorry, I'm on my break.\"\n"))))
(define* (clerk-act-be-summoned clerk message #:key who-summoned)
(match (slot-ref clerk 'state)
('on-duty
- (<- clerk who-summoned 'tell
+ (<- who-summoned 'tell
#:text
"The clerk tells you as politely as she can that she's already here,
so there's no need to ring the bell.\n"))
('slacking
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text
"The clerk's ears perk up, she stamps out a cigarette, and she
runs out of the room!\n")
(gameobj-set-loc! clerk (dyn-ref clerk 'room:lobby))
(slot-set! clerk 'patience 8)
(slot-set! clerk 'state 'on-duty)
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text
(string-append
" Suddenly, a uniformed woman rushes into the room! She's wearing a
(define* (clerk-cmd-dismiss clerk message . _)
(define player-name
- (msg-val (<-wait clerk (message-from message) 'get-name)))
+ (msg-val (<-wait (message-from message) 'get-name)))
(match (slot-ref clerk 'state)
('on-duty
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text
(format #f "\"Thanks ~a!\" says the clerk. \"I have somewhere I need to be.\"
The clerk leaves the room in a hurry.\n"
#:exclude (actor-id clerk))
(gameobj-set-loc! clerk (dyn-ref clerk 'room:break-room))
(slot-set! clerk 'state 'slacking)
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text clerk-return-to-slacking-text
#:exclude (actor-id clerk)))
('slacking
- (<- clerk (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "The clerk sternly asks you to not be so dismissive.\n"))))
(define clerk-slacking-texts
(define (clerk-act-update-loop clerk message)
(define (tell-room text)
- (<- clerk (gameobj-loc clerk) 'tell-room
+ (<- (gameobj-loc clerk) 'tell-room
#:text text
#:exclude (actor-id clerk)))
(define (loop-if-not-destructed)
;; route: it's much more live hackable. If we change the definition
;; of this method, the character will act differently on the next
;; "tick" of the loop.
- (<- clerk (actor-id clerk) 'update-loop)))
+ (<- (actor-id clerk) 'update-loop)))
(match (slot-ref clerk 'state)
('slacking
(tell-room (random-choice clerk-slacking-texts))
(wrap-apply typewriter-dispatch)))
(define (typewriter-cmd-type-gibberish actor message)
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text "*tikka takka!* *tikka takka!*
You type some gibberish on the typewriter.\n"))
(define (type-thing actor message type-text)
- (<- actor (message-from message) 'tell
+ (<- (message-from message) 'tell
#:text
(format #f "You type out a note.\nThe note says: ~s\n"
type-text)))
projects / mudsync.git / commitdiff