From: Christopher Allan Webber Date: Sat, 17 Dec 2016 00:48:57 +0000 (-0600) Subject: Update mudsync code to use easier to use action inheritance system X-Git-Tag: fosdem-2017~127 X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=ca990b14f563fc450548954184ff6fc0e4792739 Update mudsync code to use easier to use action inheritance system --- 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