Make commands use the inheritable rmeta-slot tooling

diff --git a/mudsync/command.scm b/mudsync/command.scm
index 765962ce28dcd88defa2efbfe814f029bb5440c9..a79f50d3e7f878ae24b9a1b6d8d5d98ebaeb0086 100644 (file)
--- a/mudsync/command.scm
+++ b/mudsync/command.scm
@@ -19,6 +19,7 @@
 (define-module (mudsync command)
   #:use-module (mudsync parser)
   #:use-module (8sync actors)
 (define-module (mudsync command)
   #:use-module (mudsync parser)
   #:use-module (8sync actors)

+  #:use-module (8sync rmeta-slot)

   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)


@@ -31,6 +32,8 @@
             command-action
             command-priority
 
             command-action
             command-priority
 

+            build-commands
+

             direct-command
             prep-indir-command
             prep-direct-command
             direct-command
             prep-indir-command
             prep-direct-command


@@ -69,6 +72,26 @@
   (action command-action)
   (priority command-priority))
 
   (action command-action)
   (priority command-priority))
 

+(define-syntax %build-command
+  (syntax-rules ()
+    ((_ (verb ...) ((cmd-proc action-sym args ...) ...))
+     (list (cons verb
+                 (list (cmd-proc (list verb ...)
+                                 (quote action-sym)
+                                 args ...)
+                       ...))
+           ...))
+    ((_ verb ((cmd-proc action-sym args ...) ...))
+     (list (cons verb
+                 (list (cmd-proc (list verb)
+                                 (quote action-sym)
+                                 args ...)
+                       ...))))))
+
+(define-syntax-rule (build-commands (verb-or-verbs cmd-defs ...) ...)
+  (wrap-rmeta-slot
+   (append (%build-command verb-or-verbs cmd-defs ...) ...)))
+

 
 (define (direct-command verbs action)
   (make-command verbs
 
 (define (direct-command verbs action)
   (make-command verbs

diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm
index e4146931bc7f7b2b830b7369ac58bae162f953be..00858522281f2bc5257b6b13e51fe2c14aad469c 100644 (file)
--- a/mudsync/gameobj.scm
+++ b/mudsync/gameobj.scm
@@ -23,6 +23,7 @@
   #:use-module (mudsync command)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)
   #:use-module (mudsync command)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)

+  #:use-module (8sync rmeta-slot)

   #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)


@@ -71,13 +72,16 @@
         #:init-keyword #:desc)
 
   ;; Commands we can handle
         #:init-keyword #:desc)
 
   ;; Commands we can handle

-  (commands #:init-value '())
+  (commands #:allocation #:each-subclass
+            #:init-thunk (build-commands))

 
   ;; Commands we can handle by being something's container
 
   ;; Commands we can handle by being something's container

-  (container-commands #:init-value '())
+  (container-commands #:allocation #:each-subclass
+                      #:init-thunk (build-commands))

 
   ;; Commands we can handle by being contained by something else
 
   ;; Commands we can handle by being contained by something else

-  (contained-commands #:init-value '())
+  (contained-commands #:allocation #:each-subclass
+                      #:init-thunk (build-commands))

 
   ;; Most objects are generally visible by default
   (generally-visible #:init-value #t
 
   ;; Most objects are generally visible by default
   (generally-visible #:init-value #t


@@ -173,36 +177,30 @@ Assists in its replacement of occupants if necessary and nothing else."
       (val-or-proc)
       val-or-proc))
 
       (val-or-proc)
       val-or-proc))
 

-(define (filter-commands commands verb)
-  (filter
-   (lambda (cmd)
-     (equal? (command-verbs cmd)
-             verb))
-   commands))
+(define (get-candidate-commands actor rmeta-sym verb)
+  (class-rmeta-ref (class-of actor) rmeta-sym verb
+                   #:dflt '()))

 
 (define* (gameobj-get-commands actor message #:key verb)
   "Get commands a co-occupant of the room might execute for 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))
-                     verb))
+  (define candidate-commands
+    (get-candidate-commands actor 'commands verb))

   (<-reply message
   (<-reply message

-           #:commands filtered-commands
+           #:commands candidate-commands

            #:goes-by (gameobj-goes-by actor)))
 
 (define* (gameobj-get-container-commands actor message #:key verb)
   "Get commands as the container / room of message's sender"
            #:goes-by (gameobj-goes-by actor)))
 
 (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 message #:commands filtered-commands))
+  (define candidate-commands
+    (get-candidate-commands actor 'container-commands verb))
+  (<-reply message #:commands candidate-commands))

 
 (define* (gameobj-get-contained-commands actor message #:key verb)
   "Get commands as being contained (eg inventory) of commanding gameobj"
 
 (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))
+  (define candidate-commands
+    (get-candidate-commands actor 'contained-commands verb))

   (<-reply message
   (<-reply message

-           #:commands filtered-commands
+           #:commands candidate-commands

            #:goes-by (gameobj-goes-by actor)))
 
 (define* (gameobj-add-occupant! actor message #:key who)
            #:goes-by (gameobj-goes-by actor)))
 
 (define* (gameobj-add-occupant! actor message #:key who)

diff --git a/mudsync/player.scm b/mudsync/player.scm
index bfa7ca88b0e8911810a43246cbe59ad905ba0845..bbd14030dc416a90d92478cbf83e9feda6c6fbc1 100644 (file)
--- a/mudsync/player.scm
+++ b/mudsync/player.scm
@@ -23,32 +23,27 @@
   #:use-module (mudsync parser)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)
   #:use-module (mudsync parser)
   #:use-module (8sync actors)
   #:use-module (8sync agenda)

+  #:use-module (8sync rmeta-slot)

   #:use-module (ice-9 control)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (ice-9 control)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)

-  #:export (<player>
-            player-self-commands))
+  #:export (<player>))

 
 ;;; Players
 ;;; =======
 
 
 ;;; Players
 ;;; =======
 

-(define player-self-commands
-  (list
-   (empty-command "inventory" 'cmd-inventory)
-   ;; aliases...
-   ;; @@: Should use an "alias" system for common aliases?
-   (empty-command "inv" 'cmd-inventory)
-   (empty-command "i" 'cmd-inventory)
-   (empty-command "help" 'cmd-help)))
-

 (define-class <player> (<gameobj>)
   (username #:init-keyword #:username
             #:getter player-username)
 
 (define-class <player> (<gameobj>)
   (username #:init-keyword #:username
             #:getter player-username)
 

-  (self-commands #:init-value (wrap player-self-commands))
+  (self-commands #:allocation #:each-subclass
+                 #:init-thunk
+                 (build-commands
+                  (("inventory" "inv" "i") ((empty-command cmd-inventory)))
+                  ("help" ((empty-command cmd-help)))))

 
   (actions #:allocation #:each-subclass
            #:init-thunk
 
   (actions #:allocation #:each-subclass
            #:init-thunk


@@ -191,11 +186,8 @@
 
   ;; Append our own command handlers
   (define our-commands
 
   ;; Append our own command handlers
   (define our-commands

-    (filter
-     (lambda (cmd)
-       (equal? (command-verbs cmd) verb))
-     (val-or-run
-      (slot-ref player 'self-commands))))
+    (class-rmeta-ref (class-of player) 'self-commands verb
+                     #:dflt '()))

 
   ;; Append our inventory's relevant command handlers
   (define inv-items
 
   ;; Append our inventory's relevant command handlers
   (define inv-items

diff --git a/mudsync/room.scm b/mudsync/room.scm
index 4c02e7fe3c8d3ed18601434cb0314f7d1a442763..1e0f354ec0cc01a74f51235f3b9de953a92a80bb 100644 (file)
--- a/mudsync/room.scm
+++ b/mudsync/room.scm
@@ -59,18 +59,6 @@
 ;;; Rooms
 ;;; =====
 
 ;;; Rooms
 ;;; =====
 

-(define %room-contain-commands
-  (list
-   (loose-direct-command "look" 'cmd-look-at)
-   (empty-command "look" 'cmd-look-room)
-   (empty-command "go" 'cmd-go-where)
-   (loose-direct-command "go" 'cmd-go)
-   (greedy-command "say" 'cmd-say)
-   (greedy-command "\"" 'cmd-say)
-   (greedy-command "'" 'cmd-say)
-   (greedy-command "emote" 'cmd-emote)
-   (greedy-command "/me" 'cmd-emote)))
-

 ;; TODO: Subclass from container?
 (define-class <room> (<gameobj>)
   ;; A list of <exit>
 ;; TODO: Subclass from container?
 (define-class <room> (<gameobj>)
   ;; A list of <exit>


@@ -79,7 +67,15 @@
          #:getter room-exits)
 
   (container-commands
          #:getter room-exits)
 
   (container-commands

-   #:init-value (wrap %room-contain-commands))
+   #:allocation #:each-subclass
+   #:init-thunk
+   (build-commands
+    ("look" ((loose-direct-command cmd-look-at)
+             (empty-command cmd-look-room)))
+    ("go" ((empty-command cmd-go-where)
+           (loose-direct-command cmd-go)))
+    (("say" "\"" "'") ((greedy-command cmd-say)))
+    (("emote" "/me") ((greedy-command cmd-emote)))))

 
   (actions #:allocation #:each-subclass
            #:init-thunk
 
   (actions #:allocation #:each-subclass
            #:init-thunk

diff --git a/mudsync/thing.scm b/mudsync/thing.scm
index 64ceeee5a094550584d9844ebf97957ee0cf6986..a964c50e56aea0cc5233539ce3418d8ae6fdfa3f 100644 (file)
--- a/mudsync/thing.scm
+++ b/mudsync/thing.scm
@@ -26,27 +26,7 @@
   #:use-module (oop goops)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (oop goops)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)

-  #:export (<thing>
-            thing-commands
-            thing-commands*
-            thing-contained-commands
-            thing-contained-commands*))
-
-(define thing-commands
-  (list
-   (direct-command "take" 'cmd-take)))
-
-;; Doesn't inherit anything (gameobj has no commands)
-;; so it's an alias.
-(define thing-commands* thing-commands)
-
-(define thing-contained-commands
-  (list
-   (direct-command "drop" 'cmd-drop)))
-
-;; Doesn't inherit anything (gameobj has no contained-commands)
-;; so it's an alias.
-(define thing-contained-commands* thing-contained-commands)
+  #:export (<thing>))

 
 (define-class <thing> (<gameobj>)
   ;; Can be a boolean or a procedure accepting two arguments
 
 (define-class <thing> (<gameobj>)
   ;; Can be a boolean or a procedure accepting two arguments


@@ -58,9 +38,13 @@
   (dropable #:init-value #t
             #:init-keyword #:dropable)
   (commands
   (dropable #:init-value #t
             #:init-keyword #:dropable)
   (commands

-   #:init-value (wrap thing-commands))
+   #:allocation #:each-subclass
+   #:init-thunk (build-commands
+                 ("take" ((direct-command cmd-take)))))

   (contained-commands
   (contained-commands

-   #:init-value (wrap thing-contained-commands))
+   #:allocation #:each-subclass
+   #:init-value (build-commands
+                 ("drop" ((direct-command cmd-drop)))))

   (actions #:allocation #:each-subclass
            #:init-thunk
            (build-actions
   (actions #:allocation #:each-subclass
            #:init-thunk
            (build-actions

diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm
index 8f3e580974cccf1d2fb34e08f0625fe702aa5e30..301e2e9687176923bbef5b77df677d1c47b5ee02 100644 (file)
--- a/worlds/bricabrac.scm
+++ b/worlds/bricabrac.scm
@@ -46,19 +46,13 @@
 ;;; Some simple object types.
 ;;; =========================
 
 ;;; Some simple object types.
 ;;; =========================
 

-(define readable-commands
-  (list
-   (direct-command "read" 'cmd-read)))
-
-(define readable-commands*
-  (append readable-commands
-          thing-commands))
-

 (define-class <readable> (<thing>)
   (read-text #:init-value "All it says is: \"Blah blah blah.\""
              #:init-keyword #:read-text)
   (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*)
+   #:allocation #:each-subclass
+   #:init-thunk (build-commands
+                 ("read" ((direct-command cmd-read)))))

   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-read readable-cmd-read))))
   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-read readable-cmd-read))))


@@ -80,11 +74,6 @@
   (<- (message-from message) 'tell
       #:text text-to-send))
 
   (<- (message-from message) 'tell
       #:text text-to-send))
 

-(define chat-commands
-  (list
-   (direct-command "chat" 'cmd-chat)
-   (direct-command "talk" 'cmd-chat)))
-

 (define hotel-owner-grumps
   '("Eight sinks!  Eight sinks!  And I couldn't unwind them..."
     "Don't mind the mess.  I built this place on a dare, you
 (define hotel-owner-grumps
   '("Eight sinks!  Eight sinks!  And I couldn't unwind them..."
     "Don't mind the mess.  I built this place on a dare, you


@@ -105,7 +94,9 @@ or 'skribe'?  Now *that's* composition!"))
   (catchphrases #:init-value '("Blarga blarga blarga!")
                 #:init-keyword #:catchphrases)
   (commands
   (catchphrases #:init-value '("Blarga blarga blarga!")
                 #:init-keyword #:catchphrases)
   (commands

-   #:init-value chat-commands)
+   #:allocation #:each-subclass
+   #:init-thunk (build-commands
+                 (("chat" "talk") ((direct-command cmd-chat)))))

   (actions #:allocation #:each-subclass
            #:init-thunk
            (build-actions
   (actions #:allocation #:each-subclass
            #:init-thunk
            (build-actions


@@ -113,10 +104,9 @@ or 'skribe'?  Now *that's* composition!"))
 
 (define-class <sign-in-form> (<gameobj>)
   (commands
 
 (define-class <sign-in-form> (<gameobj>)
   (commands

-   #:init-value
-   (list
-    (prep-direct-command "sign" 'cmd-sign-form
-                         '("as"))))
+   #:allocation #:each-subclass
+   #:init-thunk (build-commands
+                 ("sign" ((prep-direct-command cmd-sign-form '("as"))))))

   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-sign-form sign-cmd-sign-in))))
   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-sign-form sign-cmd-sign-in))))


@@ -150,18 +140,13 @@ Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic
 character.\n")))
 
 
 character.\n")))
 
 

-(define summoning-bell-commands
-  (list
-   (direct-command "ring" 'cmd-ring)))
-(define summoning-bell-commands*
-  (append summoning-bell-commands
-          thing-commands*))
-

 (define-class <summoning-bell> (<thing>)
   (summons #:init-keyword #:summons)
 
   (commands
 (define-class <summoning-bell> (<thing>)
   (summons #:init-keyword #:summons)
 
   (commands

-   #:init-value summoning-bell-commands*)
+   #:allocation #:each-subclass
+   #:init-thunk (build-commands
+                 ("ring" ((direct-command cmd-ring)))))

   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-ring summoning-bell-cmd-ring))))
   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-ring summoning-bell-cmd-ring))))


@@ -467,9 +452,9 @@ if this room is intended for children or child-like adults."
   (sit-name #:init-keyword #:sit-name)
 
   (commands
   (sit-name #:init-keyword #:sit-name)
 
   (commands

-   #:init-value
-   (list
-    (direct-command "sit" 'cmd-sit-furniture)))
+   #:allocation #:each-subclass
+   #:init-thunk (build-commands
+                 ("sit" ((direct-command cmd-sit-furniture)))))

   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-sit-furniture furniture-cmd-sit))))
   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
                          (cmd-sit-furniture furniture-cmd-sit))))


@@ -557,16 +542,6 @@ It has some bits of bubble gum stuck to it... yuck."
 ;;; Breakroom
 ;;; ---------
 
 ;;; Breakroom
 ;;; ---------
 

-(define clerk-commands
-  (list
-   (direct-command "talk" 'cmd-chat)
-   (direct-command "chat" 'cmd-chat)
-   (direct-command "ask" 'cmd-ask-incomplete)
-   (prep-direct-command "ask" 'cmd-ask-about)
-   (direct-command "dismiss" 'cmd-dismiss)))
-(define clerk-commands*
-  (append clerk-commands thing-commands*))
-

 (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


@@ -574,7 +549,13 @@ It has some bits of bubble gum stuck to it... yuck."
   ;;  - slacking: In the break room, probably smoking a cigarette
   ;;    or checking text messages
   (state #:init-value 'slacking)
   ;;  - slacking: In the break room, probably smoking a cigarette
   ;;    or checking text messages
   (state #:init-value 'slacking)

-  (commands #:init-value clerk-commands*)
+  (commands #:allocation #:each-subclass
+            #:init-thunk
+            (build-commands
+             (("talk" "chat") ((direct-command cmd-chat)))
+             ("ask" ((direct-command cmd-ask-incomplete)
+                     (prep-direct-command cmd-ask-about)))
+             ("dismiss" ((direct-command cmd-dismiss)))))

   (patience #:init-value 0)
   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions
   (patience #:init-value 0)
   (actions #:allocation #:each-subclass
            #:init-thunk (build-actions