From 6cff5b0062ef928204295ab4327bf2d417070421 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Mon, 12 Dec 2016 16:27:46 -0600 Subject: [PATCH 01/16] Port to the remove-define-mhandler 8sync branch --- mudsync/game-master.scm | 27 +++++++-------- mudsync/gameobj.scm | 52 +++++++++++++--------------- mudsync/networking.scm | 13 ++++--- mudsync/player.scm | 43 +++++++++++------------ mudsync/room.scm | 77 +++++++++++++++++++++-------------------- mudsync/thing.scm | 28 +++++++-------- worlds/bricabrac.scm | 47 +++++++++++++------------ worlds/goblin-hq.scm | 10 +++--- 8 files changed, 148 insertions(+), 149 deletions(-) diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm index 8bc239b..0a53389 100644 --- a/mudsync/game-master.scm +++ b/mudsync/game-master.scm @@ -63,12 +63,12 @@ ;;; .. 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 @@ -131,36 +131,35 @@ ;;; .. 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)) @@ -173,8 +172,8 @@ (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 diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 334f439..8b1040f 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -128,11 +128,9 @@ (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 @@ -145,22 +143,21 @@ (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." @@ -189,7 +186,7 @@ Assists in its replacement of occupants if necessary and nothing else." 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)) @@ -198,14 +195,14 @@ Assists in its replacement of occupants if necessary and nothing else." #: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)) @@ -214,12 +211,12 @@ Assists in its replacement of occupants if necessary and nothing else." #: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)) @@ -243,16 +240,15 @@ Assists in its replacement of occupants if necessary and nothing else." '() (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))) @@ -271,7 +267,7 @@ Assists in its replacement of occupants if necessary and nothing else." (<-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)) @@ -285,10 +281,10 @@ and whos-asking, and see if we should just return it or run it." (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) @@ -301,7 +297,7 @@ and whos-asking, and see if we should just return it or run it." 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)) @@ -326,7 +322,7 @@ By default, this is whether or not the generally-visible flag is set." ;; 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)) @@ -360,10 +356,10 @@ By default, this is whether or not the generally-visible flag is set." (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 diff --git a/mudsync/networking.scm b/mudsync/networking.scm index 230008f..bb403f8 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -48,11 +48,14 @@ (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). diff --git a/mudsync/player.scm b/mudsync/player.scm index a07c141..844aaf9 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -71,12 +71,12 @@ ;;; 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)) @@ -94,11 +94,11 @@ (<- 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 @@ -108,13 +108,14 @@ (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 '()) @@ -144,19 +145,19 @@ ;; 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... @@ -167,10 +168,9 @@ (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)) @@ -193,11 +193,10 @@ (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)) diff --git a/mudsync/room.scm b/mudsync/room.scm index c430523..2c19788 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -107,7 +107,7 @@ ;; @@: 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) @@ -119,8 +119,9 @@ (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 @@ -140,7 +141,7 @@ (<- 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")) @@ -175,10 +176,10 @@ (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) @@ -204,14 +205,12 @@ #: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." @@ -219,11 +218,10 @@ (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))) @@ -231,7 +229,7 @@ (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)) @@ -239,10 +237,10 @@ (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")) @@ -266,36 +264,39 @@ #: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 diff --git a/mudsync/thing.scm b/mudsync/thing.scm index a3ae6b0..7b3a71d 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -79,16 +79,16 @@ #: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)) @@ -108,16 +108,16 @@ #: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)) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 372515e..16f91b8 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -80,7 +80,7 @@ ;;; 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) @@ -157,11 +157,12 @@ or 'skribe'? Now *that's* composition!")) (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 @@ -199,15 +200,15 @@ character.\n"))) #: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 @@ -416,11 +417,11 @@ if this room is intended for children or child-like adults." (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) @@ -529,7 +530,7 @@ seat in the room, though." #: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 @@ -571,7 +572,7 @@ For example, 'ask clerk about changing name'. You can ask me about the following 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 @@ -584,14 +585,14 @@ with tuition at where it is...")) (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) @@ -608,7 +609,7 @@ with tuition at where it is...")) (<- 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 @@ -634,11 +635,11 @@ feel free to ask me. For example, 'ask clerk about changing name'. 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 @@ -681,7 +682,7 @@ attend to.\n") (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 diff --git a/worlds/goblin-hq.scm b/worlds/goblin-hq.scm index 357f4a6..0e1de7e 100644 --- a/worlds/goblin-hq.scm +++ b/worlds/goblin-hq.scm @@ -79,7 +79,7 @@ Only the universe knows.")) #: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")) @@ -90,12 +90,12 @@ 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)) -- 2.31.1 From aca41e2e3c5ed026c2672e3ac4ac364bbdef19c7 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Tue, 13 Dec 2016 12:45:13 -0600 Subject: [PATCH 02/16] Use msg-val everywhere and fix some definitions' argument lists. --- mudsync/game-master.scm | 3 +-- mudsync/gameobj.scm | 16 ++++++---------- mudsync/player.scm | 4 +--- mudsync/room.scm | 26 ++++++++------------------ mudsync/thing.scm | 16 ++++------------ worlds/bricabrac.scm | 26 +++++++++----------------- 6 files changed, 29 insertions(+), 62 deletions(-) diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm index 0a53389..996e51d 100644 --- a/mudsync/game-master.scm +++ b/mudsync/game-master.scm @@ -149,8 +149,7 @@ #:input data)) (define* (gm-lookup-special actor message #:key symbol) - (<-reply actor message - #:val (hash-ref (slot-ref actor 'special-dir) symbol))) + (<-reply actor 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) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 8b1040f..3250680 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -127,8 +127,7 @@ ;; Kind of a useful utility, maybe? (define (simple-slot-getter slot) (lambda (actor message) - (<-reply actor message - #:val (slot-ref actor slot)))) + (<-reply actor message (slot-ref actor slot)))) (define (gameobj-replace-step-occupants actor occupants) ;; Snarf all the occupants! @@ -249,8 +248,7 @@ Assists in its replacement of occupants if necessary and nothing else." #:occupants occupants)) (define (gameobj-act-get-loc actor message) - (<-reply actor message - #:val (slot-ref actor 'loc))) + (<-reply actor message (slot-ref actor 'loc))) (define (gameobj-set-loc! gameobj loc) "Set the location of this object." @@ -281,7 +279,7 @@ and whos-asking, and see if we should just return it or run it." (define gameobj-get-name (simple-slot-getter 'name)) -(define* (gameobj-act-set-name! actor message #:key val) +(define* (gameobj-act-set-name! actor message val) (slot-set! actor 'name val)) (define* (gameobj-get-desc actor message #:key whos-looking) @@ -290,7 +288,7 @@ and whos-asking, and see if we should just return it or run it." ((? procedure? desc-proc) (desc-proc actor whos-looking)) (desc desc))) - (<-reply actor message #:val desc-text)) + (<-reply actor message desc-text)) (define (gameobj-visible-to-player? gameobj whos-looking) "Check to see whether we're visible to the player or not. @@ -356,10 +354,8 @@ By default, this is whether or not the generally-visible flag is set." (match special-symbol ;; if it's a symbol, look it up dynamically ((? symbol? _) - (msg-receive (_ #:key val) - (<-wait gameobj (slot-ref gameobj 'gm) 'lookup-special - #:symbol special-symbol) - val)) + (msg-val (<-wait gameobj (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 diff --git a/mudsync/player.scm b/mudsync/player.scm index 844aaf9..113770f 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -113,9 +113,7 @@ (define inv-names (map (lambda (inv-item) - (msg-receive (_ #:key val) - (<-wait player inv-item 'get-name) - val)) + (msg-val (<-wait player inv-item 'get-name))) (gameobj-occupants player))) (define text-to-show (if (eq? inv-names '()) diff --git a/mudsync/room.scm b/mudsync/room.scm index 2c19788..2ebced1 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -119,9 +119,7 @@ (dyn-ref room (slot-ref exit 'to)) #f)) (define player-name - (msg-receive (_ #:key val) - (<-wait room (message-from message) 'get-name) - val)) + (msg-val (<-wait room (message-from message) 'get-name))) (cond (exit ;; Set the player's new location @@ -237,10 +235,8 @@ (cond (matching-object (let ((obj-desc - (msg-receive (_ #:key val) - (<-wait room matching-object 'get-desc - #:whos-looking (message-from message)) - val))) + (msg-val (<-wait room matching-object 'get-desc + #:whos-looking (message-from message))))) (if obj-desc (<- room (message-from message) 'tell #:text (string-append obj-desc "\n")) @@ -273,10 +269,8 @@ (define* (room-cmd-say room message #:key phrase) "Command: Say something to room participants." (define player-name - (msg-receive (_ #:key val) - (<-wait room (message-from message) - 'get-name) - val)) + (msg-val (<-wait room (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)) @@ -284,19 +278,15 @@ (define* (room-cmd-emote room message #:key phrase) "Command: Say something to room participants." (define player-name - (msg-receive (_ #:key val) - (<-wait room (message-from message) - 'get-name) - val)) + (msg-val (<-wait room (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-receive (_ #:key val) - (<-wait room who-entered 'get-name) - val)) + (msg-val (<-wait room who-entered 'get-name))) (define message-to-send (format #f "~a enters the room.\n" player-name)) (room-tell-room room message-to-send diff --git a/mudsync/thing.scm b/mudsync/thing.scm index 7b3a71d..762775d 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -82,13 +82,9 @@ (define* (thing-cmd-take thing message #:key direct-obj) (define player (message-from message)) (define player-name - (msg-receive (_ #:key val) - (<-wait thing player 'get-name) - val)) + (msg-val (<-wait thing player 'get-name))) (define player-loc - (msg-receive (_ #:key val) - (<-wait thing player 'get-loc) - val)) + (msg-val (<-wait thing player 'get-loc))) (define thing-name (slot-ref thing 'name)) (define should-take (slot-ref-maybe-runcheck thing 'takeable player)) @@ -111,13 +107,9 @@ (define* (thing-cmd-drop thing message #:key direct-obj) (define player (message-from message)) (define player-name - (msg-receive (_ #:key val) - (<-wait thing player 'get-name) - val)) + (msg-val (<-wait thing player 'get-name))) (define player-loc - (msg-receive (_ #:key val) - (<-wait thing player 'get-loc) - val)) + (msg-val (<-wait thing player 'get-loc))) (define thing-name (slot-ref thing 'name)) (define should-drop (slot-ref-maybe-runcheck thing 'dropable player)) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 16f91b8..d458327 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -160,14 +160,11 @@ or 'skribe'? Now *that's* composition!")) (define* (sign-cmd-sign-in actor message #:key direct-obj indir-obj preposition) (define old-name - (msg-receive (_ #:key val) - (<-wait actor (message-from message) 'get-name) - val)) + (msg-val (<-wait actor (message-from message) 'get-name))) (define name indir-obj) (if (valid-name? indir-obj) (begin - (<-wait actor (message-from message) 'set-name! - #:val name) + (<-wait actor (message-from message) 'set-name! name) (<- actor (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))) @@ -200,15 +197,14 @@ character.\n"))) #:init-value (simple-dispatcher summoning-bell-actions*))) -(define (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 - (msg-receive (_ #:key val) - (<-wait bell (message-from message) 'get-name) - val)) + (msg-val (<-wait bell (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 @@ -419,9 +415,7 @@ if this room is intended for children or child-like adults." (define* (furniture-cmd-sit actor message #:key direct-obj) (define player-name - (msg-receive (_ #:key val) - (<-wait actor (message-from message) 'get-name) - val)) + (msg-val (<-wait actor (message-from message) 'get-name))) (<- actor (message-from message) 'tell #:text (format #f "You ~a ~a.\n" (slot-ref actor 'sit-phrase) @@ -609,7 +603,7 @@ with tuition at where it is...")) (<- clerk (message-from message) 'tell #:text "The clerk says, \"Sorry, I'm on my break.\"\n")))) -(define (clerk-act-be-summoned clerk message who-summoned) +(define* (clerk-act-be-summoned clerk message #:key who-summoned) (match (slot-ref clerk 'state) ('on-duty (<- clerk who-summoned 'tell @@ -635,11 +629,9 @@ feel free to ask me. For example, 'ask clerk about changing name'. You can ask me about the following: " clerk-knows-about ".\"\n"))))) -(define (clerk-cmd-dismiss clerk message) +(define* (clerk-cmd-dismiss clerk message . _) (define player-name - (msg-receive (_ #:key val) - (<-wait clerk (message-from message) 'get-name) - val)) + (msg-val (<-wait clerk (message-from message) 'get-name))) (match (slot-ref clerk 'state) ('on-duty (<- clerk (gameobj-loc clerk) 'tell-room -- 2.31.1 From e585ab65215e84cb5fa12fd84ffeee0421e56d07 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Wed, 14 Dec 2016 15:15:56 -0600 Subject: [PATCH 03/16] Document why the clerk-act-update-loop calls itself --- worlds/bricabrac.scm | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index d458327..84836fa 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -674,6 +674,7 @@ attend to.\n") (define clerk-return-to-slacking-text "The desk clerk enters and slams the door behind her.\n") + (define (clerk-act-update-loop clerk message) (define (tell-room text) (<- clerk (gameobj-loc clerk) 'tell-room @@ -681,6 +682,14 @@ attend to.\n") #:exclude (actor-id clerk))) (define (loop-if-not-destructed) (if (not (slot-ref clerk 'destructed)) + ;; This iterates by "recursing" on itself by calling itself + ;; (as the message handler) again. It used to be that we had to do + ;; this, because there was a bug where a loop which yielded like this + ;; would keep growing the stack due to some parameter goofiness. + ;; That's no longer true, but there's an added advantage to this + ;; 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))) (match (slot-ref clerk 'state) ('slacking -- 2.31.1 From ca990b14f563fc450548954184ff6fc0e4792739 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 16 Dec 2016 18:48:57 -0600 Subject: [PATCH 04/16] Update mudsync code to use easier to use action inheritance system --- mudsync/game-master.scm | 19 +++++----- mudsync/gameobj.scm | 56 +++++++++++++-------------- mudsync/networking.scm | 6 ++- mudsync/player.scm | 26 ++++--------- mudsync/room.scm | 44 ++++++++-------------- mudsync/thing.scm | 24 +++--------- worlds/bricabrac.scm | 83 +++++++++++++---------------------------- 7 files changed, 95 insertions(+), 163 deletions(-) diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm index 996e51d..b8030d9 100644 --- a/mudsync/game-master.scm +++ b/mudsync/game-master.scm @@ -49,16 +49,17 @@ (new-conn-handler #:getter gm-new-conn-handler #:init-keyword #:new-conn-handler) - (message-handler + (actions + #:allocation #:each-subclass #:init-value - (make-action-dispatch - (init-world (wrap-apply gm-init-world)) - (client-input (wrap-apply gm-handle-client-input)) - (lookup-special (wrap-apply gm-lookup-special)) - (new-client (wrap-apply gm-new-client)) - (write-home (wrap-apply gm-write-home)) - (client-closed (wrap-apply gm-client-closed)) - (inject-special! (wrap-apply gm-inject-special!))))) + (mhandlers + (init-world gm-init-world) + (client-input gm-handle-client-input) + (lookup-special gm-lookup-special) + (new-client gm-new-client) + (write-home gm-write-home) + (client-closed gm-client-closed) + (inject-special! gm-inject-special!)))) ;;; .. begin world init stuff .. diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 3250680..3bb743a 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -35,7 +35,6 @@ gameobj-act-init gameobj-set-loc! gameobj-occupants - gameobj-actions gameobj-self-destruct slot-ref-maybe-runcheck @@ -47,30 +46,6 @@ ;;; ======= -;;; Actions supported by all gameobj -(define gameobj-actions - (build-actions - (init (wrap-apply gameobj-act-init)) - ;; Commands for co-occupants - (get-commands (wrap-apply gameobj-get-commands)) - ;; Commands for participants in a room - (get-container-commands (wrap-apply gameobj-get-container-commands)) - ;; Commands for inventory items, etc (occupants of the gameobj commanding) - (get-contained-commands (wrap-apply gameobj-get-contained-commands)) - (get-occupants (wrap-apply gameobj-get-occupants)) - (add-occupant! (wrap-apply gameobj-add-occupant!)) - (remove-occupant! (wrap-apply gameobj-remove-occupant!)) - (get-loc (wrap-apply gameobj-act-get-loc)) - (set-loc! (wrap-apply gameobj-act-set-loc!)) - (get-name (wrap-apply gameobj-get-name)) - (set-name! (wrap-apply gameobj-act-set-name!)) - (get-desc (wrap-apply gameobj-get-desc)) - (goes-by (wrap-apply gameobj-act-goes-by)) - (visible-name (wrap-apply gameobj-visible-name)) - (self-destruct (wrap-apply gameobj-act-self-destruct)) - (tell (wrap-apply gameobj-tell-no-op)) - (assist-replace (wrap-apply gameobj-act-assist-replace)))) - ;;; *all* game components that talk to players should somehow ;;; derive from this class. ;;; And all of them need a GM! @@ -104,10 +79,6 @@ ;; Commands we can handle by being contained by something else (contained-commands #:init-value '()) - (message-handler - #:init-value - (simple-dispatcher gameobj-actions)) - ;; Most objects are generally visible by default (generally-visible #:init-value #t #:init-keyword #:generally-visible) @@ -118,7 +89,32 @@ ;; Set this on self-destruct ;; (checked by some "long running" game routines) - (destructed #:init-value #f)) + (destructed #:init-value #f) + + (actions #:allocation #:each-subclass + ;;; Actions supported by all gameobj + #:init-value + (mhandlers + (init gameobj-act-init) + ;; Commands for co-occupants + (get-commands gameobj-get-commands) + ;; Commands for participants in a room + (get-container-commands gameobj-get-container-commands) + ;; Commands for inventory items, etc (occupants of the gameobj commanding) + (get-contained-commands gameobj-get-contained-commands) + (get-occupants gameobj-get-occupants) + (add-occupant! gameobj-add-occupant!) + (remove-occupant! gameobj-remove-occupant!) + (get-loc gameobj-act-get-loc) + (set-loc! gameobj-act-set-loc!) + (get-name gameobj-get-name) + (set-name! gameobj-act-set-name!) + (get-desc gameobj-get-desc) + (goes-by gameobj-act-goes-by) + (visible-name gameobj-visible-name) + (self-destruct gameobj-act-self-destruct) + (tell gameobj-tell-no-op) + (assist-replace gameobj-act-assist-replace)))) ;;; gameobj message handlers diff --git a/mudsync/networking.scm b/mudsync/networking.scm index bb403f8..4714556 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -45,9 +45,11 @@ ;; send input to this actor (send-input-to #:getter nm-send-input-to #:init-keyword #:send-input-to) - (message-handler + + (actions + #:allocation #:each-subclass #:init-value - (make-action-dispatch + (mhandlers (start-listening (lambda* (actor message #:key (server %default-server) diff --git a/mudsync/player.scm b/mudsync/player.scm index 113770f..8bf75b2 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -35,21 +35,6 @@ ;;; Players ;;; ======= -(define player-actions - (build-actions - (init (wrap-apply player-init)) - (handle-input (wrap-apply player-handle-input)) - (tell (wrap-apply player-tell)) - (disconnect-self-destruct (wrap-apply player-disconnect-self-destruct)) - (cmd-inventory (wrap-apply player-cmd-inventory)))) - -(define player-actions* - (append player-actions - gameobj-actions)) - -(define player-dispatcher - (simple-dispatcher player-actions*)) - (define player-self-commands (list (empty-command "inventory" 'cmd-inventory) @@ -64,9 +49,14 @@ (self-commands #:init-value player-self-commands) - (message-handler - #:init-value - (wrap-apply player-dispatcher))) + (actions #:allocation #:each-subclass + #:init-value + (mhandlers + (init player-init) + (handle-input player-handle-input) + (tell player-tell) + (disconnect-self-destruct player-disconnect-self-destruct) + (cmd-inventory player-cmd-inventory)))) ;;; player message handlers diff --git a/mudsync/room.scm b/mudsync/room.scm index 2ebced1..a3ebc65 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -24,11 +24,7 @@ #:use-module (oop goops) #:use-module (srfi srfi-1) #:use-module (ice-9 control) - #:export ( - room-actions - room-actions* - - )) + #:export ( )) ;;; Exits @@ -72,26 +68,6 @@ (greedy-command "say" 'cmd-say) (greedy-command "emote" 'cmd-emote))) -(define room-actions - (build-actions - (cmd-go (wrap-apply room-cmd-go)) - (cmd-go-where (wrap-apply room-cmd-go-where)) - (announce-entrance (wrap-apply room-announce-entrance)) - (look-room (wrap-apply room-look-room)) - (tell-room (wrap-apply room-act-tell-room)) - ;; in this case the command is the same version as the normal - ;; look-room version - (cmd-look-room (wrap-apply room-look-room)) - (cmd-look-at (wrap-apply room-look-at)) - (cmd-say (wrap-apply room-cmd-say)) - (cmd-emote (wrap-apply room-cmd-emote)))) - -(define room-actions* - (append room-actions gameobj-actions)) - -(define room-action-dispatch - (simple-dispatcher room-actions*)) - ;; TODO: Subclass from container? (define-class () ;; A list of @@ -102,10 +78,20 @@ (container-commands #:init-value (wrap %room-contain-commands)) - (message-handler - #:allocation #:each-subclass - ;; @@: Can remove this indirection once things settle - #:init-value (wrap-apply room-action-dispatch))) + (actions #:allocation #:each-subclass + #:init-value + (mhandlers + (cmd-go room-cmd-go) + (cmd-go-where room-cmd-go-where) + (announce-entrance room-announce-entrance) + (look-room room-look-room) + (tell-room room-act-tell-room) + ;; in this case the command is the same version as the normal + ;; look-room version + (cmd-look-room room-look-room) + (cmd-look-at room-look-at) + (cmd-say room-cmd-say) + (cmd-emote room-cmd-emote)))) (define* (room-cmd-go room message #:key direct-obj) (define exit diff --git a/mudsync/thing.scm b/mudsync/thing.scm index 762775d..212ad2e 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -30,9 +30,7 @@ thing-commands thing-commands* thing-contained-commands - thing-contained-commands* - thing-actions - thing-actions*)) + thing-contained-commands*)) (define thing-commands (list @@ -50,18 +48,6 @@ ;; so it's an alias. (define thing-contained-commands* thing-contained-commands) -(define thing-actions - (build-actions - (cmd-take (wrap-apply thing-cmd-take)) - (cmd-drop (wrap-apply thing-cmd-drop)))) - -(define thing-actions* - (append thing-actions - gameobj-actions)) - -(define thing-dispatcher - (simple-dispatcher thing-actions*)) - (define-class () ;; Can be a boolean or a procedure accepting two arguments ;; (thing-actor whos-acting) @@ -75,9 +61,11 @@ #:init-value (wrap thing-commands)) (contained-commands #:init-value (wrap thing-contained-commands)) - (message-handler - #:init-value - (wrap-apply thing-dispatcher))) + (actions #:allocation #:each-subclass + #:init-value + (mhandlers + (cmd-take thing-cmd-take) + (cmd-drop thing-cmd-drop)))) (define* (thing-cmd-take thing message #:key direct-obj) (define player (message-from message)) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 84836fa..e5392aa 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -54,22 +54,14 @@ (append readable-commands thing-commands)) -(define readable-actions - (build-actions - (cmd-read (wrap-apply readable-cmd-read)))) - -(define readable-actions* - (append readable-actions - thing-actions*)) - (define-class () (read-text #:init-value "All it says is: \"Blah blah blah.\"" #:init-keyword #:read-text) (commands #:init-value readable-commands*) - (message-handler - #:init-value - (simple-dispatcher readable-actions*))) + (actions #:allocation #:each-subclass + #:init-value (mhandlers + (cmd-read readable-cmd-read)))) (define (readable-cmd-read actor message) (<- actor (message-from message) 'tell @@ -92,9 +84,6 @@ (list (direct-command "chat" 'cmd-chat) (direct-command "talk" 'cmd-chat))) -(define chat-actions - (build-actions - (cmd-chat (wrap-apply npc-chat-randomly)))) (define hotel-owner-grumps '("Eight sinks! Eight sinks! And I couldn't unwind them..." @@ -117,9 +106,10 @@ or 'skribe'? Now *that's* composition!")) #:init-keyword #:catchphrases) (commands #:init-value chat-commands) - (message-handler - #:init-value - (simple-dispatcher (append gameobj-actions chat-actions)))) + (actions #:allocation #:each-subclass + #:init-value + (mhandlers + (cmd-chat npc-chat-randomly)))) (define random-bricabrac '("a creepy porcelain doll" @@ -136,14 +126,10 @@ or 'skribe'? Now *that's* composition!")) #:init-value (list (prep-direct-command "sign" 'cmd-sign-form - '("as")))) - (message-handler - #:init-value - (simple-dispatcher - (append - (build-actions - (cmd-sign-form (wrap-apply sign-cmd-sign-in))) - gameobj-actions)))) + '("as")))) + (actions #:allocation #:each-subclass + #:init-value (mhandlers + (cmd-sign-form sign-cmd-sign-in)))) (define name-sre @@ -181,21 +167,14 @@ character.\n"))) (append summoning-bell-commands thing-commands*)) -(define summoning-bell-actions - (build-actions - (cmd-ring (wrap-apply summoning-bell-cmd-ring)))) -(define summoning-bell-actions* - (append summoning-bell-actions - thing-actions*)) - (define-class () (summons #:init-keyword #:summons) (commands #:init-value summoning-bell-commands*) - (message-handler - #:init-value - (simple-dispatcher summoning-bell-actions*))) + (actions #:allocation #:each-subclass + #:init-value (mhandlers + (cmd-ring summoning-bell-cmd-ring)))) (define* (summoning-bell-cmd-ring bell message . _) ;; Call back to actor who invoked this message handler @@ -405,13 +384,9 @@ if this room is intended for children or child-like adults." #:init-value (list (direct-command "sit" 'cmd-sit-furniture))) - (message-handler - #:init-value - (simple-dispatcher - (append - (build-actions - (cmd-sit-furniture (wrap-apply furniture-cmd-sit))) - gameobj-actions)))) + (actions #:allocation #:each-subclass + #:init-value (mhandlers + (cmd-sit-furniture furniture-cmd-sit)))) (define* (furniture-cmd-sit actor message #:key direct-obj) (define player-name @@ -499,18 +474,6 @@ seat in the room, though." (define clerk-commands* (append clerk-commands thing-commands*)) -(define clerk-actions - (build-actions - (init (wrap-apply clerk-act-init)) - (cmd-chat (wrap-apply clerk-cmd-chat)) - (cmd-ask-incomplete (wrap-apply clerk-cmd-ask-incomplete)) - (cmd-ask-about (wrap-apply clerk-cmd-ask)) - (cmd-dismiss (wrap-apply clerk-cmd-dismiss)) - (update-loop (wrap-apply clerk-act-update-loop)) - (be-summoned (wrap-apply clerk-act-be-summoned)))) -(define clerk-actions* (append clerk-actions - thing-actions*)) - (define-class () ;; The desk clerk has three states: ;; - on-duty: Arrived, and waiting for instructions (and losing patience @@ -520,9 +483,15 @@ seat in the room, though." (state #:init-value 'slacking) (commands #:init-value clerk-commands*) (patience #:init-value 0) - (message-handler - #:init-value - (simple-dispatcher clerk-actions*))) + (actions #:allocation #:each-subclass + #:init-value (mhandlers + (init clerk-act-init) + (cmd-chat clerk-cmd-chat) + (cmd-ask-incomplete clerk-cmd-ask-incomplete) + (cmd-ask-about clerk-cmd-ask) + (cmd-dismiss clerk-cmd-dismiss) + (update-loop clerk-act-update-loop) + (be-summoned clerk-act-be-summoned)))) (define (clerk-act-init clerk message) ;; call the gameobj main init method -- 2.31.1 From c8c47c9d61abd219f561c020e9147d715717a16f Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Wed, 21 Dec 2016 13:05:43 -0600 Subject: [PATCH 05/16] Update to use build-actions; fix clerk communication --- mudsync.scm | 2 +- mudsync/command.scm | 2 +- mudsync/game-master.scm | 4 ++-- mudsync/gameobj.scm | 4 ++-- mudsync/networking.scm | 4 ++-- mudsync/player.scm | 4 ++-- mudsync/room.scm | 4 ++-- mudsync/run-game.scm | 4 ++-- mudsync/thing.scm | 4 ++-- worlds/bricabrac.scm | 17 +++++++++-------- worlds/goblin-hq.scm | 2 +- 11 files changed, 26 insertions(+), 25 deletions(-) diff --git a/mudsync.scm b/mudsync.scm index a3caaa1..15f4c86 100644 --- a/mudsync.scm +++ b/mudsync.scm @@ -18,7 +18,7 @@ ;;; along with Mudsync. If not, see . (define-module (mudsync) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (ice-9 format) #:use-module (ice-9 match) diff --git a/mudsync/command.scm b/mudsync/command.scm index 8672d35..765962c 100644 --- a/mudsync/command.scm +++ b/mudsync/command.scm @@ -18,7 +18,7 @@ (define-module (mudsync command) #:use-module (mudsync parser) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (ice-9 control) diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm index b8030d9..b11d21c 100644 --- a/mudsync/game-master.scm +++ b/mudsync/game-master.scm @@ -18,7 +18,7 @@ (define-module (mudsync game-master) #:use-module (mudsync networking) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (oop goops) #:use-module (ice-9 match) @@ -52,7 +52,7 @@ (actions #:allocation #:each-subclass #:init-value - (mhandlers + (build-actions (init-world gm-init-world) (client-input gm-handle-client-input) (lookup-special gm-lookup-special) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 3bb743a..07b3ddb 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -21,7 +21,7 @@ (define-module (mudsync gameobj) #:use-module (mudsync command) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (srfi srfi-1) #:use-module (ice-9 format) @@ -94,7 +94,7 @@ (actions #:allocation #:each-subclass ;;; Actions supported by all gameobj #:init-value - (mhandlers + (build-actions (init gameobj-act-init) ;; Commands for co-occupants (get-commands gameobj-get-commands) diff --git a/mudsync/networking.scm b/mudsync/networking.scm index 4714556..c2c1068 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -17,7 +17,7 @@ ;;; along with Mudsync. If not, see . (define-module (mudsync networking) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (ice-9 format) #:use-module (ice-9 match) @@ -49,7 +49,7 @@ (actions #:allocation #:each-subclass #:init-value - (mhandlers + (build-actions (start-listening (lambda* (actor message #:key (server %default-server) diff --git a/mudsync/player.scm b/mudsync/player.scm index 8bf75b2..e3ae2ba 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -21,7 +21,7 @@ #:use-module (mudsync gameobj) #:use-module (mudsync game-master) #:use-module (mudsync parser) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (ice-9 control) #:use-module (ice-9 format) @@ -51,7 +51,7 @@ (actions #:allocation #:each-subclass #:init-value - (mhandlers + (build-actions (init player-init) (handle-input player-handle-input) (tell player-tell) diff --git a/mudsync/room.scm b/mudsync/room.scm index a3ebc65..efb52d8 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -19,7 +19,7 @@ (define-module (mudsync room) #:use-module (mudsync command) #:use-module (mudsync gameobj) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (oop goops) #:use-module (srfi srfi-1) @@ -80,7 +80,7 @@ (actions #:allocation #:each-subclass #:init-value - (mhandlers + (build-actions (cmd-go room-cmd-go) (cmd-go-where room-cmd-go-where) (announce-entrance room-announce-entrance) diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm index 6bacfcd..95fedb0 100644 --- a/mudsync/run-game.scm +++ b/mudsync/run-game.scm @@ -20,8 +20,8 @@ #:use-module (mudsync game-master) #:use-module (8sync agenda) #:use-module (8sync repl) - #:use-module (8sync systems actors) - #:use-module (8sync systems actors debug) + #:use-module (8sync actors) + #:use-module (8sync debug) #:use-module (srfi srfi-1) #:use-module (ice-9 receive) #:use-module (ice-9 q) diff --git a/mudsync/thing.scm b/mudsync/thing.scm index 212ad2e..6963c01 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -21,7 +21,7 @@ (define-module (mudsync thing) #:use-module (mudsync command) #:use-module (mudsync gameobj) - #:use-module (8sync systems actors) + #:use-module (8sync actors) #:use-module (8sync agenda) #:use-module (oop goops) #:use-module (ice-9 match) @@ -63,7 +63,7 @@ #:init-value (wrap thing-contained-commands)) (actions #:allocation #:each-subclass #:init-value - (mhandlers + (build-actions (cmd-take thing-cmd-take) (cmd-drop thing-cmd-drop)))) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index e5392aa..daf6353 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -20,7 +20,7 @@ (use-modules (mudsync) (mudsync parser) - (8sync systems actors) + (8sync actors) (8sync agenda) (oop goops) (ice-9 control) @@ -60,7 +60,7 @@ (commands #:init-value readable-commands*) (actions #:allocation #:each-subclass - #:init-value (mhandlers + #:init-value (build-actions (cmd-read readable-cmd-read)))) (define (readable-cmd-read actor message) @@ -108,7 +108,7 @@ or 'skribe'? Now *that's* composition!")) #:init-value chat-commands) (actions #:allocation #:each-subclass #:init-value - (mhandlers + (build-actions (cmd-chat npc-chat-randomly)))) (define random-bricabrac @@ -128,7 +128,7 @@ or 'skribe'? Now *that's* composition!")) (prep-direct-command "sign" 'cmd-sign-form '("as")))) (actions #:allocation #:each-subclass - #:init-value (mhandlers + #:init-value (build-actions (cmd-sign-form sign-cmd-sign-in)))) @@ -173,7 +173,7 @@ character.\n"))) (commands #:init-value summoning-bell-commands*) (actions #:allocation #:each-subclass - #:init-value (mhandlers + #:init-value (build-actions (cmd-ring summoning-bell-cmd-ring)))) (define* (summoning-bell-cmd-ring bell message . _) @@ -385,7 +385,7 @@ if this room is intended for children or child-like adults." (list (direct-command "sit" 'cmd-sit-furniture))) (actions #:allocation #:each-subclass - #:init-value (mhandlers + #:init-value (build-actions (cmd-sit-furniture furniture-cmd-sit)))) (define* (furniture-cmd-sit actor message #:key direct-obj) @@ -484,7 +484,7 @@ seat in the room, though." (commands #:init-value clerk-commands*) (patience #:init-value 0) (actions #:allocation #:each-subclass - #:init-value (mhandlers + #:init-value (build-actions (init clerk-act-init) (cmd-chat clerk-cmd-chat) (cmd-ask-incomplete clerk-cmd-ask-incomplete) @@ -555,7 +555,8 @@ with tuition at where it is...")) (define clerk-doesnt-know-text "The clerk apologizes and says she doesn't know about that topic.\n") -(define (clerk-cmd-ask clerk message indir-obj) +(define* (clerk-cmd-ask clerk message #:key indir-obj + #:allow-other-keys) (match (slot-ref clerk 'state) ('on-duty (match (assoc (pk 'indir indir-obj) clerk-help-topics) diff --git a/worlds/goblin-hq.scm b/worlds/goblin-hq.scm index 0e1de7e..3330a10 100644 --- a/worlds/goblin-hq.scm +++ b/worlds/goblin-hq.scm @@ -17,7 +17,7 @@ ;;; along with Mudsync. If not, see . (use-modules (mudsync) - (8sync systems actors) + (8sync actors) (8sync agenda) (oop goops) (ice-9 format)) -- 2.31.1 From d45f1aca89f7f664137c16c0b6a3b39dc7445ffd Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Sun, 1 Jan 2017 18:47:44 -0600 Subject: [PATCH 06/16] Use new --- mudsync/run-game.scm | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm index 95fedb0..9b7c149 100644 --- a/mudsync/run-game.scm +++ b/mudsync/run-game.scm @@ -61,30 +61,30 @@ (define gm (hive-create-actor-gimmie* hive "gm" #:new-conn-handler new-conn-handler)) + (define repl-manager + (hive-create-actor* hive "repl")) + (define initial-tasks (list (bootstrap-message hive (actor-id gm) 'init-world - #:game-spec game-spec))) + #:game-spec game-spec) + (apply bootstrap-message hive repl-manager 'init + (if (string? repl-server) + `(#:path ,repl-server) + '())))) + (define agenda (make-agenda #:pre-unwind-handler print-error-and-continue #:queue (list->q initial-tasks))) (set! %live-gm gm) (set! %live-hive hive) + (receive (post-run-hook gameobj-injector) (make-special-injector agenda hive (actor-id gm)) ;; Set up injector for live hacking (set! inject-gameobj! gameobj-injector) - ;; Set up REPL sever - (cond - ;; If repl-server is an integer, we'll use that as the port - ((integer? repl-server) - (spawn-and-queue-repl-server! agenda repl-server)) - (repl-server - (spawn-and-queue-repl-server! agenda))) - - (start-agenda agenda - #:post-run-hook post-run-hook))) + (start-agenda agenda #:post-run-hook post-run-hook))) (define (do-inject-special! queue hive gm-id game-spec special-symbol) -- 2.31.1 From d23f2cefbde148dedc61da5cf35391a12c6734bb Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Sun, 1 Jan 2017 18:48:09 -0600 Subject: [PATCH 07/16] Only keep looping while the actor is alive --- mudsync/networking.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/mudsync/networking.scm b/mudsync/networking.scm index c2c1068..f12a7e0 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -147,7 +147,8 @@ (begin (nm-handle-line nm client client-id (string-trim-right line #\return)) - (loop)))) + (when (actor-am-i-alive? nm) + (loop))))) (loop)) (define (nm-handle-port-closed nm client client-id) -- 2.31.1 From 701425bc611abaa8b4140942d995d5f32d24e2d7 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Mon, 2 Jan 2017 16:37:16 -0600 Subject: [PATCH 08/16] Rename call of start-agenda to run-agenda --- mudsync/run-game.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm index 9b7c149..f3035d3 100644 --- a/mudsync/run-game.scm +++ b/mudsync/run-game.scm @@ -84,7 +84,7 @@ ;; Set up injector for live hacking (set! inject-gameobj! gameobj-injector) - (start-agenda agenda #:post-run-hook post-run-hook))) + (run-agenda agenda #:post-run-hook post-run-hook))) (define (do-inject-special! queue hive gm-id game-spec special-symbol) -- 2.31.1 From 754bd427883ab189433fad90293e05d9aced2f70 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Mon, 2 Jan 2017 19:29:34 -0600 Subject: [PATCH 09/16] Update all actor usage of <- to not pass in from-actor. Unless necessary, in which case use <-*. --- mudsync/game-master.scm | 32 +++++++++++------------ mudsync/gameobj.scm | 32 +++++++++++------------ mudsync/networking.scm | 11 ++++---- mudsync/player.scm | 28 +++++++++----------- mudsync/room.scm | 36 ++++++++++++------------- mudsync/thing.scm | 20 +++++++------- worlds/bricabrac.scm | 58 ++++++++++++++++++++--------------------- worlds/goblin-hq.scm | 4 +-- 8 files changed, 108 insertions(+), 113 deletions(-) diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm index b11d21c..4576de3 100644 --- a/mudsync/game-master.scm +++ b/mudsync/game-master.scm @@ -106,7 +106,7 @@ (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) @@ -114,7 +114,7 @@ (for-each (lambda (special-obj) (format #t "Initializing ~s...\n" (address->string special-obj)) - (<-wait gm special-obj 'init)) + (<-wait special-obj 'init)) specials)) @@ -125,7 +125,7 @@ #: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) @@ -146,16 +146,16 @@ ;; 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)) @@ -167,7 +167,7 @@ ;; 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))) @@ -192,19 +192,19 @@ using the gameobj-spec." #: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 @@ -220,7 +220,7 @@ using the gameobj-spec." (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)))) @@ -246,10 +246,10 @@ with an anonymous persona" ;; 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))))) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 07b3ddb..8efe565 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -123,7 +123,7 @@ ;; 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! @@ -131,7 +131,7 @@ (when occupants (for-each (lambda (occupant) - (<-wait actor occupant 'set-loc! + (<-wait occupant 'set-loc! #:loc (actor-id actor))) occupants))) @@ -141,7 +141,7 @@ (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)) @@ -165,8 +165,7 @@ Assists in its replacement of occupants if necessary and nothing else." (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" @@ -186,7 +185,7 @@ Assists in its replacement of occupants if necessary and nothing else." (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))) @@ -195,14 +194,14 @@ Assists in its replacement of occupants if necessary and nothing else." (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))) @@ -240,11 +239,10 @@ Assists in its replacement of occupants if necessary and nothing else." (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." @@ -256,9 +254,9 @@ Assists in its replacement of occupants if necessary and nothing else." (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) @@ -284,7 +282,7 @@ and whos-asking, and see if we should just return it or run it." ((? 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. @@ -306,7 +304,7 @@ By default, this is whether or not the generally-visible flag is set." 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" @@ -338,7 +336,7 @@ By default, this is whether or not the generally-visible flag is set." ;; 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))) @@ -350,7 +348,7 @@ By default, this is whether or not the generally-visible flag is set." (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) diff --git a/mudsync/networking.scm b/mudsync/networking.scm index f12a7e0..d2593d1 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -135,7 +135,7 @@ (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) @@ -147,7 +147,7 @@ (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)) @@ -155,18 +155,19 @@ "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)) diff --git a/mudsync/player.scm b/mudsync/player.scm index e3ae2ba..1063955 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -63,7 +63,7 @@ (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) @@ -79,20 +79,20 @@ (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)))) @@ -103,7 +103,7 @@ (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 '()) @@ -113,7 +113,7 @@ (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 @@ -134,9 +134,8 @@ (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) @@ -144,7 +143,7 @@ (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 @@ -157,8 +156,8 @@ (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)) @@ -182,8 +181,7 @@ (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) diff --git a/mudsync/room.scm b/mudsync/room.scm index efb52d8..0ad886c 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -105,28 +105,28 @@ (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 @@ -160,7 +160,7 @@ (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))) @@ -185,7 +185,7 @@ (string-append room-text occupant-names-string) room-text)) - (<- room player-id 'tell + (<- player-id 'tell #:text final-text)) @@ -203,7 +203,7 @@ (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) @@ -221,15 +221,15 @@ (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")))) @@ -242,7 +242,7 @@ (if wait <-wait <-)) - (deliver-method room tell-me 'tell + (deliver-method tell-me 'tell #:text text)) who-to-tell)) @@ -255,8 +255,7 @@ (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)) @@ -264,15 +263,14 @@ (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 diff --git a/mudsync/thing.scm b/mudsync/thing.scm index 6963c01..f2e2180 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -70,9 +70,9 @@ (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)) @@ -80,24 +80,24 @@ ;; 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)) @@ -105,14 +105,14 @@ ;; 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)))) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index daf6353..7570b0d 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -64,7 +64,7 @@ (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"))) @@ -77,7 +77,7 @@ (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 @@ -146,15 +146,15 @@ or 'skribe'? Now *that's* composition!")) (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"))) @@ -182,13 +182,13 @@ 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 @@ -196,7 +196,7 @@ character.\n"))) ;; 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) @@ -204,7 +204,7 @@ character.\n"))) ;; 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))) @@ -390,12 +390,12 @@ if this room is intended for children or child-like adults." (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) @@ -497,7 +497,7 @@ seat in the room, though." ;; 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" . @@ -538,10 +538,10 @@ with tuition at where it is...")) (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, \"" @@ -549,7 +549,7 @@ with tuition at where it is...")) "\"\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 @@ -561,34 +561,34 @@ with tuition at where it is...")) ('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 @@ -601,10 +601,10 @@ You can ask me about the following: (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" @@ -612,11 +612,11 @@ 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 @@ -647,7 +647,7 @@ attend to.\n") (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) @@ -660,7 +660,7 @@ attend to.\n") ;; 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)) diff --git a/worlds/goblin-hq.scm b/worlds/goblin-hq.scm index 3330a10..6bfd154 100644 --- a/worlds/goblin-hq.scm +++ b/worlds/goblin-hq.scm @@ -80,12 +80,12 @@ Only the universe knows.")) (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))) -- 2.31.1 From e6bd5ce0dd5edd77d182f70e6a32101e999f8623 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Tue, 3 Jan 2017 20:25:24 -0600 Subject: [PATCH 10/16] Update calls of hive-create-actor to bootstrap-actor --- mudsync/run-game.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm index f3035d3..fe7cb51 100644 --- a/mudsync/run-game.scm +++ b/mudsync/run-game.scm @@ -59,10 +59,10 @@ (define new-conn-handler (make-default-room-conn-handler default-room)) (define gm - (hive-create-actor-gimmie* hive "gm" - #:new-conn-handler new-conn-handler)) + (bootstrap-actor-gimmie* hive "gm" + #:new-conn-handler new-conn-handler)) (define repl-manager - (hive-create-actor* hive "repl")) + (bootstrap-actor* hive "repl")) (define initial-tasks (list (bootstrap-message hive (actor-id gm) 'init-world -- 2.31.1 From ed1ef3172af4c2621e2b746824b7defa6f0dcedd Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Wed, 4 Jan 2017 10:39:04 -0600 Subject: [PATCH 11/16] Rename msg-foo to mbody-foo --- mudsync/gameobj.scm | 6 +++--- mudsync/player.scm | 10 +++++----- mudsync/room.scm | 12 ++++++------ mudsync/thing.scm | 8 ++++---- worlds/bricabrac.scm | 8 ++++---- 5 files changed, 22 insertions(+), 22 deletions(-) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 8efe565..44602df 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -140,7 +140,7 @@ (define (run-replacement actor replaces replace-steps) (when replaces - (msg-receive (_ #:key occupants) + (mbody-receive (_ #:key occupants) (<-wait replaces 'assist-replace) (for-each (lambda (replace-step) @@ -348,8 +348,8 @@ By default, this is whether or not the generally-visible flag is set." (match special-symbol ;; if it's a symbol, look it up dynamically ((? symbol? _) - (msg-val (<-wait (slot-ref gameobj 'gm) 'lookup-special - #:symbol special-symbol))) + (mbody-val (<-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 diff --git a/mudsync/player.scm b/mudsync/player.scm index 1063955..a0caf23 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -103,7 +103,7 @@ (define inv-names (map (lambda (inv-item) - (msg-val (<-wait inv-item 'get-name))) + (mbody-val (<-wait inv-item 'get-name))) (gameobj-occupants player))) (define text-to-show (if (eq? inv-names '()) @@ -133,7 +133,7 @@ ;; Ask the room for its commands (define room-commands ;; TODO: Map room id and sort - (msg-receive (_ #:key commands) + (mbody-receive (_ #:key commands) (<-wait player-loc 'get-container-commands #:verb verb) commands)) @@ -142,7 +142,7 @@ (define co-occupants (remove (lambda (x) (equal? x (actor-id player))) - (msg-receive (_ #:key occupants) + (mbody-receive (_ #:key occupants) (<-wait player-loc 'get-occupants) occupants))) @@ -155,7 +155,7 @@ (define co-occupant-commands (fold (lambda (co-occupant prev) - (msg-receive (_ #:key commands goes-by) + (mbody-receive (_ #:key commands goes-by) (<-wait co-occupant 'get-commands #:verb verb) (append @@ -180,7 +180,7 @@ (define inv-item-commands (fold (lambda (inv-item prev) - (msg-receive (_ #:key commands goes-by) + (mbody-receive (_ #:key commands goes-by) (<-wait inv-item 'get-contained-commands #:verb verb) (append diff --git a/mudsync/room.scm b/mudsync/room.scm index 0ad886c..aaedd5c 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -105,7 +105,7 @@ (dyn-ref room (slot-ref exit 'to)) #f)) (define player-name - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-val (<-wait (message-from message) 'get-name))) (cond (exit ;; Set the player's new location @@ -202,7 +202,7 @@ (lambda (return) (for-each (lambda (occupant) - (msg-receive (_ #:key goes-by) + (mbody-receive (_ #:key goes-by) (<-wait occupant 'goes-by) (if (member called-this goes-by) (return occupant)))) @@ -221,7 +221,7 @@ (cond (matching-object (let ((obj-desc - (msg-val (<-wait matching-object 'get-desc + (mbody-val (<-wait matching-object 'get-desc #:whos-looking (message-from message))))) (if obj-desc (<- (message-from message) 'tell @@ -255,7 +255,7 @@ (define* (room-cmd-say room message #:key phrase) "Command: Say something to room participants." (define player-name - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-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)) @@ -263,14 +263,14 @@ (define* (room-cmd-emote room message #:key phrase) "Command: Say something to room participants." (define player-name - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-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 who-entered 'get-name))) + (mbody-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 diff --git a/mudsync/thing.scm b/mudsync/thing.scm index f2e2180..6399c6f 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -70,9 +70,9 @@ (define* (thing-cmd-take thing message #:key direct-obj) (define player (message-from message)) (define player-name - (msg-val (<-wait player 'get-name))) + (mbody-val (<-wait player 'get-name))) (define player-loc - (msg-val (<-wait player 'get-loc))) + (mbody-val (<-wait player 'get-loc))) (define thing-name (slot-ref thing 'name)) (define should-take (slot-ref-maybe-runcheck thing 'takeable player)) @@ -95,9 +95,9 @@ (define* (thing-cmd-drop thing message #:key direct-obj) (define player (message-from message)) (define player-name - (msg-val (<-wait player 'get-name))) + (mbody-val (<-wait player 'get-name))) (define player-loc - (msg-val (<-wait player 'get-loc))) + (mbody-val (<-wait player 'get-loc))) (define thing-name (slot-ref thing 'name)) (define should-drop (slot-ref-maybe-runcheck thing 'dropable player)) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 7570b0d..ba0b75f 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -146,7 +146,7 @@ or 'skribe'? Now *that's* composition!")) (define* (sign-cmd-sign-in actor message #:key direct-obj indir-obj preposition) (define old-name - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-val (<-wait (message-from message) 'get-name))) (define name indir-obj) (if (valid-name? indir-obj) (begin @@ -182,7 +182,7 @@ character.\n"))) ;; handler... meanwhile, this procedure suspends until we get ;; their response. (define who-rang - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-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. @@ -390,7 +390,7 @@ if this room is intended for children or child-like adults." (define* (furniture-cmd-sit actor message #:key direct-obj) (define player-name - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-val (<-wait (message-from message) 'get-name))) (<- (message-from message) 'tell #:text (format #f "You ~a ~a.\n" (slot-ref actor 'sit-phrase) @@ -601,7 +601,7 @@ You can ask me about the following: (define* (clerk-cmd-dismiss clerk message . _) (define player-name - (msg-val (<-wait (message-from message) 'get-name))) + (mbody-val (<-wait (message-from message) 'get-name))) (match (slot-ref clerk 'state) ('on-duty (<- (gameobj-loc clerk) 'tell-room -- 2.31.1 From c31ed97997815c39bd516a45c1106ce5fbf7bc04 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 19 Jan 2017 13:55:39 -0600 Subject: [PATCH 12/16] Better gameobj-inject! system. Also now use run-hive. --- mudsync/run-game.scm | 87 ++++++++++++++++++-------------------------- 1 file changed, 36 insertions(+), 51 deletions(-) diff --git a/mudsync/run-game.scm b/mudsync/run-game.scm index fe7cb51..0fed48d 100644 --- a/mudsync/run-game.scm +++ b/mudsync/run-game.scm @@ -18,13 +18,13 @@ (define-module (mudsync run-game) #:use-module (mudsync game-master) - #:use-module (8sync agenda) + #:use-module (8sync) #:use-module (8sync repl) - #:use-module (8sync actors) #:use-module (8sync debug) #:use-module (srfi srfi-1) #:use-module (ice-9 receive) #:use-module (ice-9 q) + #:use-module (ice-9 match) #:export (run-demo do-inject-special! make-special-injector @@ -46,9 +46,32 @@ ;; "quasi-evil for productivity's sake" anyway). You can set up your own ;; solution which doesn't use a global though. +(define %inject-queue #f) + (define (inject-gameobj! game-spec special-symbol) - (display "Game hasn't been started...\n")) + (if %inject-queue + (let ((gameobj-spec + (or (find + (lambda (entry) (eq? (car entry) special-symbol)) + game-spec) + (throw 'no-such-symbol "Can't find such a symbol in the game-spec" + #:symbol special-symbol)))) + (enq! %inject-queue (cons gameobj-spec special-symbol))) + (display "Game hasn't been started...\n")) + 'done) + +(define-actor () + ((repl-update gameobj-injector-inject-queued)) + (gm #:init-keyword #:gm + #:getter .gm)) +(define (gameobj-injector-inject-queued injector message) + (while (not (q-empty? %inject-queue)) + (match (deq! %inject-queue) + ((gameobj-spec . special-symbol) + (<- (.gm injector) 'inject-special! + #:special-symbol special-symbol + #:gameobj-spec gameobj-spec))))) ;;; Game running stuff @@ -61,57 +84,19 @@ (define gm (bootstrap-actor-gimmie* hive "gm" #:new-conn-handler new-conn-handler)) - (define repl-manager - (bootstrap-actor* hive "repl")) - - (define initial-tasks - (list (bootstrap-message hive (actor-id gm) 'init-world - #:game-spec game-spec) - (apply bootstrap-message hive repl-manager 'init - (if (string? repl-server) - `(#:path ,repl-server) - '())))) + (define injector + (bootstrap-actor hive + #:gm (actor-id gm))) - (define agenda - (make-agenda #:pre-unwind-handler print-error-and-continue - #:queue (list->q initial-tasks))) + (define repl-manager + (bootstrap-actor* hive "repl" + #:subscribers (list injector))) (set! %live-gm gm) (set! %live-hive hive) - (receive (post-run-hook gameobj-injector) - (make-special-injector agenda hive (actor-id gm)) - ;; Set up injector for live hacking - (set! inject-gameobj! gameobj-injector) - - (run-agenda agenda #:post-run-hook post-run-hook))) - - -(define (do-inject-special! queue hive gm-id game-spec special-symbol) - (define gameobj-spec - (or (find - (lambda (entry) (eq? (car entry) special-symbol)) - game-spec) - (throw 'no-such-symbol "Can't find such a symbol in the game-spec" - #:symbol special-symbol))) - (define task - (bootstrap-message hive gm-id 'inject-special! - #:special-symbol special-symbol - #:gameobj-spec gameobj-spec)) - (enq! queue task) - 'done) - -(define (queue-injected-tasks-on-agenda! agenda inject-queue) - "Inject tasks from the inject-queue onto the agenda queue." - (while (not (q-empty? inject-queue)) - (enq! (agenda-queue agenda) (q-pop! inject-queue)))) + (set! %inject-queue (make-q)) -(define* (make-special-injector agenda hive gm-id) - "Make a post-run-hook and gameobj injector for quick live hacking." - (define inject-queue (make-q)) - (values - (lambda (agenda) - (queue-injected-tasks-on-agenda! agenda inject-queue)) - (lambda (game-spec special-symbol) - (do-inject-special! inject-queue hive gm-id - game-spec special-symbol)))) + (run-hive hive + (list (bootstrap-message hive (actor-id gm) 'init-world + #:game-spec game-spec)))) -- 2.31.1 From b1bf0fc9ec0ffcc06b7b1d4e422f3e28a00a27a6 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 19 Jan 2017 13:56:10 -0600 Subject: [PATCH 13/16] Clean up the networking code a bit. --- mudsync/networking.scm | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/mudsync/networking.scm b/mudsync/networking.scm index d2593d1..f30a1b9 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -37,27 +37,24 @@ (define %default-server #f) (define %default-port 8889) -(define-class () +(define-actor () + ((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))) + (new-client nm-new-client)) + (server-socket #:getter nm-server-socket) ;; mapping of client -> client-id (clients #:getter nm-clients #:init-thunk make-hash-table) ;; send input to this actor (send-input-to #:getter nm-send-input-to - #:init-keyword #:send-input-to) - - (actions - #:allocation #:each-subclass - #:init-value - (build-actions - (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)))))) + #:init-keyword #:send-input-to)) ;;; TODO: We should provide something like this, but this isn't used currently, ;;; and uses old deprecated code (the 8sync-port-remove stuff). @@ -121,10 +118,11 @@ (let loop () ;; (yield) ;; @@: Do we need this? (define client-connection (accept s)) - (8sync (nm-new-client nm s client-connection)) + (<- (actor-id nm) 'new-client + s client-connection) (loop))) -(define (nm-new-client nm s client-connection) +(define (nm-new-client nm message s client-connection) "Handle new client coming in to socket S" (define client-details (cdr client-connection)) (define client (car client-connection)) @@ -135,7 +133,7 @@ (sockaddr:addr client-details))) (fcntl client F_SETFL (logior O_NONBLOCK (fcntl client F_GETFL))) (hash-set! (nm-clients nm) client-id client) - (<-* `(#:actor ,nm) (nm-send-input-to nm) 'new-client #:client client-id) + (<- (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) -- 2.31.1 From f45624ba340380a78970a1330620b6b15744ae87 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 20 Jan 2017 10:39:38 -0600 Subject: [PATCH 14/16] Add infrastructure for static files, etc --- .gitignore | 1 + Makefile.am | 1 + configure.ac | 10 ++++++-- env.in | 16 ------------ mudsync/package-config.scm.in | 47 +++++++++++++++++++++++++++++++++++ pre-inst-env.in | 5 +++- 6 files changed, 61 insertions(+), 19 deletions(-) delete mode 100644 env.in create mode 100644 mudsync/package-config.scm.in diff --git a/.gitignore b/.gitignore index 4312890..e857c64 100644 --- a/.gitignore +++ b/.gitignore @@ -32,3 +32,4 @@ install-sh /build-aux/missing /build-aux/test-driver /build-aux/texinfo.tex +/mudsync/package-config.scm diff --git a/Makefile.am b/Makefile.am index 583ce10..f9dfd9b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -54,6 +54,7 @@ SOURCES = \ mudsync/room.scm \ mudsync/run-game.scm \ mudsync/thing.scm \ + mudsync/package-config.scm \ mudsync.scm # TESTS = \ diff --git a/configure.ac b/configure.ac index 34ed107..2fb1d62 100644 --- a/configure.ac +++ b/configure.ac @@ -10,7 +10,13 @@ m4_ifdef([GUILE_PROGS], GUILE_PROGS -AC_CONFIG_FILES([Makefile]) -AC_CONFIG_FILES([env], [chmod +x env]) +dnl Prepare a version of $datadir that does not contain references to +dnl shell variables. (Borrowed from Sly, which borrowed from Guix...) +package_prefix="`eval echo $prefix | sed -e"s|NONE|/usr/local|g"`" +package_datadir="`eval eval echo $datadir | sed -e "s|NONE|$package_prefix|g"`" +AC_SUBST([package_datadir]) + + +AC_CONFIG_FILES([Makefile mudsync/package-config.scm]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) AC_OUTPUT diff --git a/env.in b/env.in deleted file mode 100644 index a681bdc..0000000 --- a/env.in +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/sh - -## Also borrowed from guile-opengl, which is GPLv3+ - -GUILE_LOAD_PATH=@abs_top_srcdir@:$GUILE_LOAD_PATH -if test "@abs_top_srcdir@" != "@abs_top_builddir@"; then - GUILE_LOAD_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH -fi -GUILE_LOAD_COMPILED_PATH=@abs_top_builddir@:$GUILE_LOAD_PATH -PATH=@abs_top_builddir@/bin:$PATH - -export GUILE_LOAD_PATH -export GUILE_LOAD_COMPILED_PATH -export PATH - -exec "$@" diff --git a/mudsync/package-config.scm.in b/mudsync/package-config.scm.in new file mode 100644 index 0000000..97fabf5 --- /dev/null +++ b/mudsync/package-config.scm.in @@ -0,0 +1,47 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2017 Christopher Allan Webber +;;; +;;; 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 . + +(define-module (mudsync package-config) + #:export (%datadir + scope-datadir web-static-filepath + + %mudsync-package-name %mudsync-version)) + +(define %datadir + (or (getenv "MUDSYNC_DATADIR") + "@package_datadir@/@PACKAGE_NAME@")) + +(define (scope-datadir filename) + (string-append %datadir filename)) + +(define (web-static-filepath filename) + (scope-datadir (string-append "/web-static" filename))) + + +(define %mudsync-package-name + "@PACKAGE_NAME@") + +(define %mudsync-version + "@PACKAGE_VERSION@") + +;; (define %mudsync-bug-report-address +;; "@PACKAGE_BUGREPORt") + +;; (define %mudsync-home-page-url +;; "@PACKAGE_URL@") + diff --git a/pre-inst-env.in b/pre-inst-env.in index 4bec38d..5b67513 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -2,7 +2,7 @@ # srt2vtt --- SRT to WebVTT converter # Copyright © 2015 David Thompson -# Copyright © 2015 Christopher Allan Webber +# Copyright © 2015, 2017 Christopher Allan Webber # # srt2vtt is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -24,6 +24,9 @@ GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_ GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH +MUDSYNC_DATADIR="$abs_top_builddir/data" +export MUDSYNC_DATADIR + PATH="$abs_top_builddir/scripts:$PATH" export PATH -- 2.31.1 From 16299416786d528400f22d4d0c07bd3bbeb90ae3 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 20 Jan 2017 10:41:54 -0600 Subject: [PATCH 15/16] Basic infrastructure for websocket support --- mudsync/networking.scm | 96 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 94 insertions(+), 2 deletions(-) diff --git a/mudsync/networking.scm b/mudsync/networking.scm index f30a1b9..6f60ad9 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -1,5 +1,5 @@ ;;; Mudsync --- Live hackable MUD -;;; Copyright © 2016 Christopher Allan Webber +;;; Copyright © 2016-2017 Christopher Allan Webber ;;; ;;; This file is part of Mudsync. ;;; @@ -19,11 +19,21 @@ (define-module (mudsync networking) #:use-module (8sync actors) #:use-module (8sync agenda) + #:use-module (8sync systems websocket server) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) #:use-module (oop goops) + ;; used by web server only + #:use-module (sxml simple) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (mudsync package-config) + #:use-module (rnrs io ports) + #:export (;; Should we be exporting these? %default-server %default-port @@ -36,18 +46,24 @@ (define %default-server #f) (define %default-port 8889) +(define %default-web-server-port 8888) (define-actor () ((start-listening (lambda* (actor message #:key (server %default-server) - (port %default-port)) + (port %default-port) + (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))) (send-to-client (lambda* (actor message #:key client data) (nm-send-to-client-id actor client data))) (new-client nm-new-client)) + (web-server #:accessor .web-server) + (server-socket #:getter nm-server-socket) ;; mapping of client -> client-id (clients #:getter nm-clients @@ -178,3 +194,79 @@ #:client-id client-id #:data data)) (display data client-obj)) + + + +;;; Web server interface + +(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) + (pk 'web-server (create-actor nm + #:port web-server-port + #:http-handler (wrap-apply http-handler) + #:websocket-handler (wrap-apply websocket-handler))))) + +(define (view:main-display request body) + (define body-tmpl + '(body + (@ (style "display: flex; flex-direction: column; align-content: stretch; align-items: stretch;")) + (div (@ (style "background: #555555; flex: 1;") + (id "stream-output")) + (p "nope")) + (div (@ (id "input-box") + (style "flex: 1; background: #000055;")) + (p "test test") + (input (@ (id "input")))))) + + (define (main-tmpl) + `(html (@ (xmlns "http://www.w3.org/1999/xhtml") + (style "width: 100%; height: 100%;")) + (head + (title "Mudsync!") + (meta (@ (charset "UTF-8")))) + ,body-tmpl)) + (define (write-template-to-string) + (with-fluids ((%default-port-encoding "UTF-8")) + (with-output-to-string + (lambda () + (sxml->xml (main-tmpl)))))) + (values (build-response #:code 200 + #:headers '((content-type . (application/xhtml+xml)))) + (write-template-to-string))) + +(define (view:render-static request body static-path) + (values (build-response #:code 200 + ;; #:content-type (mime-type static-path) + ) + (call-with-input-file (web-static-filepath static-path) get-bytevector-all))) + +(define (view:standard-four-oh-four . args) + (values (build-response #:code 404 + #:headers '((content-type . (text/plain)))) + "Four-oh-four! Not found.")) + +(define (route request) + (match (split-and-decode-uri-path (uri-path (request-uri request))) + (() (values view:main-display '())) + + (("static" static-path ...) + ;; TODO: make this toggle'able + (values view:render-static + (list (string-append "/" (string-join + static-path "/"))))) + + ;; Not found! + (_ (values view:standard-four-oh-four '())))) + +(define (http-handler request body) + (receive (view args) + (route request) + (apply view request body args))) + +;; Respond to text messages by reversing the message. Respond to +;; binary messages with "hello". +(define (websocket-handler data) + (if (string? data) + (string-reverse data) + "hello")) -- 2.31.1 From d97fa236de7c359ac318819062131137e3064082 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Fri, 20 Jan 2017 11:07:37 -0600 Subject: [PATCH 16/16] Full screen css structure --- data/web-static/css/main.css | 29 +++++++++++++++++++++++++++++ mudsync/networking.scm | 20 ++++++++------------ 2 files changed, 37 insertions(+), 12 deletions(-) create mode 100644 data/web-static/css/main.css diff --git a/data/web-static/css/main.css b/data/web-static/css/main.css new file mode 100644 index 0000000..fdf3955 --- /dev/null +++ b/data/web-static/css/main.css @@ -0,0 +1,29 @@ +*, *:before, *:after { + box-sizing: border-box; +} + + +body { + height: 100%; + display: flex; + flex-direction: column; + border: 0px; + margin: 0px; +} + +#stream-output { + flex: 1; + min-height: 85vh; + max-height: 85vh; + background-color: #d5d5d5; + padding: 10px; +} + +#input-box { + flex: 1; + min-height: 15vh; + max-height: 15vh; + background-color: #414141; + color: #d5d5d5; + padding: 10px; +} \ No newline at end of file diff --git a/mudsync/networking.scm b/mudsync/networking.scm index 6f60ad9..f69f47a 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -209,23 +209,19 @@ (define (view:main-display request body) (define body-tmpl - '(body - (@ (style "display: flex; flex-direction: column; align-content: stretch; align-items: stretch;")) - (div (@ (style "background: #555555; flex: 1;") - (id "stream-output")) + '((div (@ (id "stream-output")) (p "nope")) - (div (@ (id "input-box") - (style "flex: 1; background: #000055;")) + (div (@ (id "input-box")) (p "test test") (input (@ (id "input")))))) (define (main-tmpl) - `(html (@ (xmlns "http://www.w3.org/1999/xhtml") - (style "width: 100%; height: 100%;")) - (head - (title "Mudsync!") - (meta (@ (charset "UTF-8")))) - ,body-tmpl)) + `(html (@ (xmlns "http://www.w3.org/1999/xhtml")) + (head (title "Mudsync!") + (meta (@ (charset "UTF-8"))) + (link (@ (rel "stylesheet") + (href "/static/css/main.css")))) + (body ,@body-tmpl))) (define (write-template-to-string) (with-fluids ((%default-port-encoding "UTF-8")) (with-output-to-string -- 2.31.1