projects
/
mudsync.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (from parent 1:
8df4394
)
Make commands use the inheritable rmeta-slot tooling
author
Christopher Allan Webber
<cwebber@dustycloud.org>
Wed, 25 Jan 2017 20:19:57 +0000
(14:19 -0600)
committer
Christopher Allan Webber
<cwebber@dustycloud.org>
Wed, 25 Jan 2017 20:19:57 +0000
(14:19 -0600)
mudsync/command.scm
patch
|
blob
|
history
mudsync/gameobj.scm
patch
|
blob
|
history
mudsync/player.scm
patch
|
blob
|
history
mudsync/room.scm
patch
|
blob
|
history
mudsync/thing.scm
patch
|
blob
|
history
worlds/bricabrac.scm
patch
|
blob
|
history
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