;;; .. begin world init stuff ..
-(define (gm-init-world gm message)
+(define* (gm-init-world gm message #:key game-spec)
;; Load database
;; TODO
;; Init basic rooms / structure
- (gm-init-game-spec gm (message-ref message 'game-spec))
+ (gm-init-game-spec gm game-spec)
;; Restore database-based actors
;; TODO
;;; .. end world init stuff ...
-(define-mhandler (gm-new-client actor message client)
+(define* (gm-new-client actor message #:key client)
;; @@: Maybe more indirection than needed for this
((gm-new-conn-handler actor) actor client))
-(define (gm-handle-client-input actor message)
+(define* (gm-handle-client-input actor message
+ #:key client data)
"Handle input from a client."
- (define client-id (message-ref message 'client))
- (define input (message-ref message 'data))
;; Look up player
- (define player (hash-ref (gm-client-dir actor) client-id))
+ (define player (hash-ref (gm-client-dir actor) client))
;; debugging
- (format #t "DEBUG: From ~s: ~s\n" client-id input)
+ (format #t "DEBUG: From ~s: ~s\n" client data)
(<- actor player 'handle-input
- #:input input))
+ #:input data))
-(define-mhandler (gm-lookup-special actor message symbol)
+(define* (gm-lookup-special actor message #:key symbol)
(<-reply actor message
#:val (hash-ref (slot-ref actor 'special-dir) symbol)))
-(define-mhandler (gm-write-home actor message text)
+(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
#:client client-id
#:data text))
-(define-mhandler (gm-client-closed gm message client)
+(define* (gm-client-closed gm message #:key client)
;; Do we have this client registered to an actor? Get the id if so.
(define actor-id (hash-ref (gm-client-dir gm) client))
(gm-unregister-client! gm client)))
-(define-mhandler (gm-inject-special! gm message
- special-symbol gameobj-spec)
+(define* (gm-inject-special! gm message
+ #:key special-symbol gameobj-spec)
"Inject, possiibly replacing the original, special symbol
using the gameobj-spec."
(define existing-obj
(define (simple-slot-getter slot)
(lambda (actor message)
(<-reply actor message
- #:val (slot-ref actor slot))))
+ #:val (slot-ref actor slot))))
-(define (gameobj-replace-step-occupants actor replace-reply)
- (define occupants
- (message-ref replace-reply 'occupants #f))
+(define (gameobj-replace-step-occupants actor occupants)
;; Snarf all the occupants!
(display "replacing occupant\n")
(when occupants
(define gameobj-replace-steps*
(list gameobj-replace-step-occupants))
-(define (run-replacement actor message replace-steps)
- (define replaces (message-ref message 'replace #f))
+(define (run-replacement actor replaces replace-steps)
(when replaces
- (let ((replace-reply
- (<-wait actor replaces 'assist-replace)))
+ (msg-receive (_ #:key occupants)
+ (<-wait actor replaces 'assist-replace)
(for-each
(lambda (replace-step)
- (replace-step actor replace-reply))
+ (replace-step actor occupants))
replace-steps))))
;; @@: This could be kind of a messy way of doing gameobj-act-init
;; stuff. If only we had generic methods :(
-(define-mhandler (gameobj-act-init actor message)
+(define* (gameobj-act-init actor message #:key replace)
"Your most basic game object init procedure.
Assists in its replacement of occupants if necessary and nothing else."
- (run-replacement actor message gameobj-replace-steps*))
+ (run-replacement actor replace gameobj-replace-steps*))
(define (gameobj-goes-by gameobj)
"Find the name we go by. Defaults to #:name if nothing else provided."
verb))
commands))
-(define-mhandler (gameobj-get-commands actor message verb)
+(define* (gameobj-get-commands actor message #:key verb)
"Get commands a co-occupant of the room might execute for VERB"
(define filtered-commands
(filter-commands (val-or-run (slot-ref actor 'commands))
#:commands filtered-commands
#:goes-by (gameobj-goes-by actor)))
-(define-mhandler (gameobj-get-container-commands actor message verb)
+(define* (gameobj-get-container-commands actor message #:key verb)
"Get commands as the container / room of message's sender"
(define filtered-commands
(filter-commands (val-or-run (slot-ref actor 'container-commands))
verb))
(<-reply actor message #:commands filtered-commands))
-(define-mhandler (gameobj-get-contained-commands actor message verb)
+(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))
#:commands filtered-commands
#:goes-by (gameobj-goes-by actor)))
-(define-mhandler (gameobj-add-occupant! actor message who)
+(define* (gameobj-add-occupant! actor message #:key who)
"Add an actor to our list of present occupants"
(hash-set! (slot-ref actor 'occupants)
who #t))
-(define-mhandler (gameobj-remove-occupant! actor message who)
+(define* (gameobj-remove-occupant! actor message #:key who)
"Remove an occupant from the room."
(hash-remove! (slot-ref actor 'occupants) who))
'()
(slot-ref gameobj 'occupants)))
-(define-mhandler (gameobj-get-occupants actor message)
+(define* (gameobj-get-occupants actor message #:key exclude)
"Get all present occupants of the room."
- (define exclude (message-ref message 'exclude #f))
(define occupants
(gameobj-occupants actor #:exclude exclude))
(<-reply actor message
#:occupants occupants))
-(define-mhandler (gameobj-act-get-loc actor message)
+(define (gameobj-act-get-loc actor message)
(<-reply actor message
#:val (slot-ref actor 'loc)))
(<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))))
;; @@: Should it really be #:id ? Maybe #:loc-id or #:loc?
-(define-mhandler (gameobj-act-set-loc! actor message loc)
+(define* (gameobj-act-set-loc! actor message #:key loc)
"Action routine to set the location."
(gameobj-set-loc! actor loc))
(define gameobj-get-name (simple-slot-getter 'name))
-(define-mhandler (gameobj-act-set-name! actor message val)
+(define* (gameobj-act-set-name! actor message #:key val)
(slot-set! actor 'name val))
-(define-mhandler (gameobj-get-desc actor message whos-looking)
+(define* (gameobj-get-desc actor message #:key whos-looking)
(define desc-text
(match (slot-ref actor 'desc)
((? procedure? desc-proc)
By default, this is whether or not the generally-visible flag is set."
(slot-ref gameobj 'generally-visible))
-(define-mhandler (gameobj-visible-name actor message whos-looking)
+(define* (gameobj-visible-name actor message #:key whos-looking)
;; Are we visible?
(define we-are-visible
((slot-ref actor 'visible-to-player?) actor whos-looking))
;; Boom!
(self-destruct gameobj))
-(define-mhandler (gameobj-act-self-destruct gameobj message)
+(define (gameobj-act-self-destruct gameobj message)
"Action routine for self destruction"
(gameobj-self-destruct gameobj))
(match special-symbol
;; if it's a symbol, look it up dynamically
((? symbol? _)
- (message-ref
- (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special
- #:symbol special-symbol)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special
+ #:symbol special-symbol)
+ val))
;; if it's false, return nothing
(#f #f)
;; otherwise it's probably an address, return it as-is
(message-handler
#:init-value
(make-action-dispatch
- ((start-listening actor message)
- (nm-install-socket actor (message-ref message 'server %default-server)
- (message-ref message 'port %default-port)))
- ((send-to-client actor message client data)
- (nm-send-to-client-id actor client data)))))
+ (start-listening
+ (lambda* (actor message
+ #:key (server %default-server)
+ (port %default-port))
+ (nm-install-socket actor server port)))
+ (send-to-client
+ (lambda* (actor message #:key client data)
+ (nm-send-to-client-id actor client data))))))
;;; TODO: We should provide something like this, but this isn't used currently,
;;; and uses old deprecated code (the 8sync-port-remove stuff).
;;; player message handlers
-(define-mhandler (player-init player message)
+(define (player-init player message)
;; Look around the room we're in
(<- player (gameobj-loc player) 'look-room))
-(define-mhandler (player-handle-input player message input)
+(define* (player-handle-input player message #:key input)
(define split-input (split-verb-and-rest input))
(define input-verb (car split-input))
(define input-rest (cdr split-input))
(<- player (gameobj-gm player) 'write-home
#:text "Huh?\n"))))
-(define-mhandler (player-tell player message text)
+(define* (player-tell player message #:key text)
(<- player (gameobj-gm player) 'write-home
#:text text))
-(define-mhandler (player-disconnect-self-destruct player message)
+(define (player-disconnect-self-destruct player message)
"Action routine for being told to disconnect and self destruct."
(define loc (gameobj-loc player))
(when loc
(slot-ref player 'name))))
(gameobj-self-destruct player))
-(define-mhandler (player-cmd-inventory player message)
+(define (player-cmd-inventory player message)
"Display the inventory for the player"
(define inv-names
(map
(lambda (inv-item)
- (message-ref (<-wait player inv-item 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait player inv-item 'get-name)
+ val))
(gameobj-occupants player)))
(define text-to-show
(if (eq? inv-names '())
;; Ask the room for its commands
(define room-commands
;; TODO: Map room id and sort
- (message-ref
- (<-wait player player-loc
+ (msg-receive (_ #:key commands)
+ (<-wait player player-loc
'get-container-commands
#:verb verb)
- 'commands))
+ commands))
;; All the co-occupants of the room (not including ourself)
(define co-occupants
(remove
(lambda (x) (equal? x (actor-id player)))
- (message-ref
- (<-wait player player-loc 'get-occupants)
- 'occupants)))
+ (msg-receive (_ #:key occupants)
+ (<-wait player player-loc 'get-occupants)
+ occupants)))
;; @@: There's a race condition here if someone leaves the room
;; during this, heh...
(define co-occupant-commands
(fold
(lambda (co-occupant prev)
- (let* ((result (<-wait player co-occupant 'get-commands
- #:verb verb))
- (commands (message-ref result 'commands))
- (goes-by (message-ref result 'goes-by)))
+ (msg-receive (_ #:key commands goes-by)
+ (<-wait player co-occupant 'get-commands
+ #:verb verb)
(append
(map (lambda (command)
(list command goes-by co-occupant))
(define inv-item-commands
(fold
(lambda (inv-item prev)
- (let* ((result (<-wait player inv-item
- 'get-contained-commands
- #:verb verb))
- (commands (message-ref result 'commands))
- (goes-by (message-ref result 'goes-by)))
+ (msg-receive (_ #:key commands goes-by)
+ (<-wait player inv-item
+ 'get-contained-commands
+ #:verb verb)
(append
(map (lambda (command)
(list command goes-by inv-item))
;; @@: Can remove this indirection once things settle
#:init-value (wrap-apply room-action-dispatch)))
-(define-mhandler (room-cmd-go room message direct-obj)
+(define* (room-cmd-go room message #:key direct-obj)
(define exit
(find
(lambda (exit)
(dyn-ref room (slot-ref exit 'to))
#f))
(define player-name
- (message-ref (<-wait room (message-from message)
- 'get-name) 'val))
+ (msg-receive (_ #:key val)
+ (<-wait room (message-from message) 'get-name)
+ val))
(cond
(exit
;; Set the player's new location
(<- room (message-from message) 'tell
#:text "You don't see any way to go there.\n"))))
-(define-mhandler (room-cmd-go-where room message)
+(define (room-cmd-go-where room message)
(<- room (message-from message) 'tell
#:text "Go where?\n"))
(define occupant-names-all
(map
(lambda (occupant)
- (message-ref
- (<-wait room occupant 'visible-name
- #:whos-looking player-id)
- 'text))
+ (call-with-message (<-wait room occupant 'visible-name
+ #:whos-looking player-id)
+ (lambda* (_ #:key text)
+ text)))
(remove
(lambda (x) (equal? x player-id))
(hash-map->list (lambda (x _) x)
#:text final-text))
-(define-mhandler (room-look-room room message)
+(define* (room-look-room room message
+ ;; Either send it to the #:to-id of the message,
+ ;; or to the sender of the message
+ #:key (to-id (message-from message)))
"Command: Player asks to look around the room"
- (room-player-looks-around
- room
- ;; Either send it to the #:to-id of the message, or to the
- ;; sender of the message
- (message-ref message 'to-id
- (message-from message))))
+ (room-player-looks-around room to-id))
(define (room-find-thing-called room called-this)
"Find something called CALLED-THIS in the room, if any."
(lambda (return)
(for-each
(lambda (occupant)
- (define goes-by
- (message-ref (<-wait room occupant 'goes-by)
- 'goes-by #f))
- (if (member called-this goes-by)
- (return occupant)))
+ (msg-receive (_ #:key goes-by)
+ (<-wait room occupant 'goes-by)
+ (if (member called-this goes-by)
+ (return occupant))))
(hash-map->list (lambda (key val) key)
(slot-ref room 'occupants)))
#f)))
(define %formless-desc
"You don't see anything special.")
-(define-mhandler (room-look-at room message direct-obj)
+(define* (room-look-at room message #:key direct-obj)
"Look at a specific object in the room."
(define matching-object
(room-find-thing-called room direct-obj))
(cond
(matching-object
(let ((obj-desc
- (message-ref
- (<-wait room matching-object 'get-desc
- #:whos-looking (message-from message))
- 'val)))
+ (msg-receive (_ #:key val)
+ (<-wait room matching-object 'get-desc
+ #:whos-looking (message-from message))
+ val)))
(if obj-desc
(<- room (message-from message) 'tell
#:text (string-append obj-desc "\n"))
#:text text))
who-to-tell))
-(define-mhandler (room-act-tell-room room message text)
+(define* (room-act-tell-room room message #:key text exclude wait)
"Tell the room some messages."
- (define exclude (message-ref message 'exclude #f))
- (define wait-delivery (message-ref message 'wait #f))
(room-tell-room room text
#:exclude exclude
- #:wait wait-delivery))
+ #:wait wait))
-(define-mhandler (room-cmd-say room message phrase)
+(define* (room-cmd-say room message #:key phrase)
"Command: Say something to room participants."
(define player-name
- (message-ref (<-wait room (message-from message)
- 'get-name) 'val))
+ (msg-receive (_ #:key val)
+ (<-wait room (message-from message)
+ 'get-name)
+ val))
(define message-to-send
(format #f "~a says: ~a\n" player-name phrase))
(room-tell-room room message-to-send))
-(define-mhandler (room-cmd-emote room message phrase)
+(define* (room-cmd-emote room message #:key phrase)
"Command: Say something to room participants."
(define player-name
- (message-ref (<-wait room (message-from message)
- 'get-name) 'val))
+ (msg-receive (_ #:key val)
+ (<-wait room (message-from message)
+ 'get-name)
+ val))
(define message-to-send
(format #f "* ~a ~a\n" player-name phrase))
(room-tell-room room message-to-send))
-(define-mhandler (room-announce-entrance room message who-entered)
+(define* (room-announce-entrance room message #:key who-entered)
(define player-name
- (message-ref (<-wait room who-entered 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait room who-entered 'get-name)
+ val))
(define message-to-send
(format #f "~a enters the room.\n" player-name))
(room-tell-room room message-to-send
#:init-value
(wrap-apply thing-dispatcher)))
-(define-mhandler (thing-cmd-take thing message direct-obj)
+(define* (thing-cmd-take thing message #:key direct-obj)
(define player (message-from message))
(define player-name
- (message-ref
- (<-wait thing player 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait thing player 'get-name)
+ val))
(define player-loc
- (message-ref
- (<-wait thing player 'get-loc)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait thing player 'get-loc)
+ val))
(define thing-name (slot-ref thing 'name))
(define should-take
(slot-ref-maybe-runcheck thing 'takeable player))
#:text (format #f "It doesn't seem like you can pick up ~a.\n"
thing-name))))
-(define-mhandler (thing-cmd-drop thing message direct-obj)
+(define* (thing-cmd-drop thing message #:key direct-obj)
(define player (message-from message))
(define player-name
- (message-ref
- (<-wait thing player 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait thing player 'get-name)
+ val))
(define player-loc
- (message-ref
- (<-wait thing player 'get-loc)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait thing player 'get-loc)
+ val))
(define thing-name (slot-ref thing 'name))
(define should-drop
(slot-ref-maybe-runcheck thing 'dropable player))
;;; Lobby
;;; -----
-(define-mhandler (npc-chat-randomly actor message)
+(define (npc-chat-randomly actor message . _)
(define text-to-send
(format #f "~a says: \"~a\"\n"
(slot-ref actor 'name)
(and (irregex-match name-sre name)
(not (member name forbidden-words))))
-(define-mhandler (sign-cmd-sign-in actor message direct-obj indir-obj)
+(define* (sign-cmd-sign-in actor message
+ #:key direct-obj indir-obj preposition)
(define old-name
- (message-ref
- (<-wait actor (message-from message) 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait actor (message-from message) 'get-name)
+ val))
(define name indir-obj)
(if (valid-name? indir-obj)
(begin
#:init-value
(simple-dispatcher summoning-bell-actions*)))
-(define-mhandler (summoning-bell-cmd-ring bell message)
+(define (summoning-bell-cmd-ring bell message)
;; Call back to actor who invoked this message handler
;; 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
- (message-ref
- (<-wait bell (message-from message) 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait bell (message-from message) 'get-name)
+ val))
;; 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
(cmd-sit-furniture (wrap-apply furniture-cmd-sit)))
gameobj-actions))))
-(define-mhandler (furniture-cmd-sit actor message direct-obj)
+(define* (furniture-cmd-sit actor message #:key direct-obj)
(define player-name
- (message-ref
- (<-wait actor (message-from message) 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait actor (message-from message) 'get-name)
+ val))
(<- actor (message-from message) 'tell
#:text (format #f "You ~a ~a.\n"
(slot-ref actor 'sit-phrase)
#:init-value
(simple-dispatcher clerk-actions*)))
-(define-mhandler (clerk-act-init clerk message)
+(define (clerk-act-init clerk message)
;; call the gameobj main init method
(gameobj-act-init clerk message)
;; start our main loop
energy particle physicist. But ya gotta pay the bills, especially
with tuition at where it is..."))
-(define-mhandler (clerk-cmd-chat clerk message)
+(define* (clerk-cmd-chat clerk message #:key direct-obj)
(match (slot-ref clerk 'state)
('on-duty
(<- clerk (message-from message) 'tell
(random-choice clerk-slacking-complaints)
"\"\n")))))
-(define-mhandler (clerk-cmd-ask-incomplete clerk message)
+(define (clerk-cmd-ask-incomplete clerk message)
(<- clerk (message-from message) 'tell
#:text "The clerk says, \"Ask about what?\"\n"))
(define clerk-doesnt-know-text
"The clerk apologizes and says she doesn't know about that topic.\n")
-(define-mhandler (clerk-cmd-ask clerk message indir-obj)
+(define (clerk-cmd-ask clerk message indir-obj)
(match (slot-ref clerk 'state)
('on-duty
(match (assoc (pk 'indir indir-obj) clerk-help-topics)
(<- clerk (message-from message) 'tell
#:text "The clerk says, \"Sorry, I'm on my break.\"\n"))))
-(define-mhandler (clerk-act-be-summoned clerk message who-summoned)
+(define (clerk-act-be-summoned clerk message who-summoned)
(match (slot-ref clerk 'state)
('on-duty
(<- clerk who-summoned 'tell
You can ask me about the following:
" clerk-knows-about ".\"\n")))))
-(define-mhandler (clerk-cmd-dismiss clerk message)
+(define (clerk-cmd-dismiss clerk message)
(define player-name
- (message-ref
- (<-wait clerk (message-from message) 'get-name)
- 'val))
+ (msg-receive (_ #:key val)
+ (<-wait clerk (message-from message) 'get-name)
+ val))
(match (slot-ref clerk 'state)
('on-duty
(<- clerk (gameobj-loc clerk) 'tell-room
(define clerk-return-to-slacking-text
"The desk clerk enters and slams the door behind her.\n")
-(define-mhandler (clerk-act-update-loop clerk message)
+(define (clerk-act-update-loop clerk message)
(define (tell-room text)
(<- clerk (gameobj-loc clerk) 'tell-room
#:text text
#:init-value
(wrap-apply typewriter-dispatch)))
-(define-mhandler (typewriter-cmd-type-gibberish actor message)
+(define (typewriter-cmd-type-gibberish actor message)
(<- actor (message-from message) 'tell
#:text "*tikka takka!* *tikka takka!*
You type some gibberish on the typewriter.\n"))
(format #f "You type out a note.\nThe note says: ~s\n"
type-text)))
-(define-mhandler (typewriter-cmd-type-something
- actor message direct-obj indir-obj)
+(define (typewriter-cmd-type-something
+ actor message direct-obj indir-obj)
(type-thing actor message direct-obj))
-(define-mhandler (typewriter-cmd-type-anything
- actor message direct-obj rest)
+(define (typewriter-cmd-type-anything
+ actor message direct-obj rest)
(type-thing actor message rest))
projects / mudsync.git / commitdiff