From: Christopher Allan Webber <cwebber@dustycloud.org>
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/?a=commitdiff_plain;h=ca990b14f563fc450548954184ff6fc0e4792739;p=mudsync.git

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>
-            room-actions
-            room-actions*
-
-            <exit>))
+  #:export (<room> <exit>))
 
 
 ;;; 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 <room> (<gameobj>)
   ;; A list of <exit>
@@ -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 <thing> (<gameobj>)
   ;; 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 <readable> (<thing>)
   (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 <summoning-bell> (<thing>)
   (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 <desk-clerk> (<thing>)
   ;; 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