Update mudsync code to use easier to use action inheritance system

diff --git a/mudsync/game-master.scm b/mudsync/game-master.scm
index 996e51da52d692d0888fbb14c13bdbb37581d332..b8030d9d72a4f2114183576683561909e726fd1c 100644 (file)
--- 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)
 
   (new-conn-handler #:getter gm-new-conn-handler
                     #:init-keyword #:new-conn-handler)
 

-  (message-handler
+  (actions
+   #:allocation #:each-subclass

    #:init-value
    #: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 ..
 
 
 ;;; .. begin world init stuff ..

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index 32506803cfa43bbf71cd764caf3a458122e76de4..3bb743ac5101e09182c0c5e6020c931d73394e10 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -35,7 +35,6 @@
             gameobj-act-init
             gameobj-set-loc!
             gameobj-occupants
             gameobj-act-init
             gameobj-set-loc!
             gameobj-occupants

-            gameobj-actions

             gameobj-self-destruct
 
             slot-ref-maybe-runcheck
             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!
 ;;; *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 '())
 
   ;; 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)
   ;; 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)
 
   ;; 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
 
 
 ;;; gameobj message handlers

diff --git a/mudsync/networking.scm b/mudsync/networking.scm
index bb403f8f998fe1755076515114ba74f94590d870..4714556b4427595ec1e1b1ee2694880bd5be8bd2 100644 (file)
--- 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)
   ;; 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
    #:init-value

-   (make-action-dispatch
+   (mhandlers

     (start-listening
      (lambda* (actor message
                      #:key (server %default-server)
     (start-listening
      (lambda* (actor message
                      #:key (server %default-server)

diff --git a/mudsync/player.scm b/mudsync/player.scm
index 113770f72aa5d43ce23a34a87c95f4b8adfb5aa1..8bf75b2c0e9e59100ae2a8dd3dec465d7152674c 100644 (file)
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -35,21 +35,6 @@
 ;;; Players
 ;;; =======
 
 ;;; 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)
 (define player-self-commands
   (list
    (empty-command "inventory" 'cmd-inventory)


@@ -64,9 +49,14 @@
 
   (self-commands #:init-value player-self-commands)
 
 
   (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
 
 
 ;;; player message handlers

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 2ebced12060491561486f37fce574bb60caa452e..a3ebc65908212063e2d60b9a21d8f7afe30d60c6 100644 (file)
--- 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)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 control)

-  #:export (<room>
-            room-actions
-            room-actions*
-
-            <exit>))
+  #:export (<room> <exit>))

 
 \f
 ;;; Exits
 
 \f
 ;;; Exits


@@ -72,26 +68,6 @@
    (greedy-command "say" 'cmd-say)
    (greedy-command "emote" 'cmd-emote)))
 
    (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>
 ;; TODO: Subclass from container?
 (define-class <room> (<gameobj>)
   ;; A list of <exit>


@@ -102,10 +78,20 @@
   (container-commands
    #:init-value (wrap %room-contain-commands))
 
   (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
 
 (define* (room-cmd-go room message #:key direct-obj)
   (define exit

diff --git a/mudsync/thing.scm b/mudsync/thing.scm
index 762775d318a6a16a1ab85a2d65ab49c4c4e63654..212ad2e11c20963afa6f6c47c057afa561d3b4db 100644 (file)
--- a/mudsync/thing.scm
+++ b/mudsync/thing.scm
@@ -30,9 +30,7 @@
             thing-commands
             thing-commands*
             thing-contained-commands
             thing-commands
             thing-commands*
             thing-contained-commands

-            thing-contained-commands*
-            thing-actions
-            thing-actions*))
+            thing-contained-commands*))

 
 (define thing-commands
   (list
 
 (define thing-commands
   (list


@@ -50,18 +48,6 @@
 ;; so it's an alias.
 (define thing-contained-commands* thing-contained-commands)
 
 ;; 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)
 (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))
    #: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))
 
 (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 84836fa7690ab0c19d81eeca9105f70ed3b1716d..e5392aaa428222699a8012e7046e48c76545d20a 100644 (file)
--- a/worlds/bricabrac.scm
+++ b/worlds/bricabrac.scm
@@ -54,22 +54,14 @@
   (append readable-commands
           thing-commands))
 
   (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*)
 (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
 
 (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)))
   (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..."
 
 (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)
                 #: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"
 
 (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
    #: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
 
 
 (define name-sre


@@ -181,21 +167,14 @@ character.\n")))
   (append summoning-bell-commands
           thing-commands*))
 
   (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*)
 (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
 
 (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)))
    #: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
 
 (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-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
 (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)
   (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
 
 (define (clerk-act-init clerk message)
   ;; call the gameobj main init method