From: Christopher Allan Webber Date: Wed, 25 Jan 2017 20:19:57 +0000 (-0600) Subject: Make commands use the inheritable rmeta-slot tooling X-Git-Tag: fosdem-2017~81 X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=4d4af0656b0402e630eea9393420197152945e5b;p=mudsync.git Make commands use the inheritable rmeta-slot tooling --- diff --git a/mudsync/command.scm b/mudsync/command.scm index 765962c..a79f50d 100644 --- a/mudsync/command.scm +++ b/mudsync/command.scm @@ -19,6 +19,7 @@ (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) @@ -31,6 +32,8 @@ command-action command-priority + build-commands + direct-command prep-indir-command prep-direct-command @@ -69,6 +72,26 @@ (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 diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index e414693..0085852 100644 --- 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 (8sync rmeta-slot) #: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 - (commands #:init-value '()) + (commands #:allocation #:each-subclass + #:init-thunk (build-commands)) ;; 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 - (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 @@ -173,36 +177,30 @@ Assists in its replacement of occupants if necessary and nothing else." (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 filtered-commands - (filter-commands (val-or-run (slot-ref actor 'commands)) - verb)) + (define candidate-commands + (get-candidate-commands actor 'commands verb)) (<-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" - (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 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 - #:commands filtered-commands + #:commands candidate-commands #: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 bfa7ca8..bbd1403 100644 --- 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 (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) - #:export ( - player-self-commands)) + #:export ()) ;;; 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 () (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 @@ -191,11 +186,8 @@ ;; 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 diff --git a/mudsync/room.scm b/mudsync/room.scm index 4c02e7f..1e0f354 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -59,18 +59,6 @@ ;;; 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 () ;; A list of @@ -79,7 +67,15 @@ #: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 diff --git a/mudsync/thing.scm b/mudsync/thing.scm index 64ceeee..a964c50 100644 --- 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) - #:export ( - 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 ()) (define-class () ;; Can be a boolean or a procedure accepting two arguments @@ -58,9 +38,13 @@ (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 - #: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 diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 8f3e580..301e2e9 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -46,19 +46,13 @@ ;;; Some simple object types. ;;; ========================= -(define readable-commands - (list - (direct-command "read" 'cmd-read))) - -(define readable-commands* - (append readable-commands - thing-commands)) - (define-class () (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)))) @@ -80,11 +74,6 @@ (<- (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 @@ -105,7 +94,9 @@ or 'skribe'? Now *that's* composition!")) (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 @@ -113,10 +104,9 @@ or 'skribe'? Now *that's* composition!")) (define-class () (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)))) @@ -150,18 +140,13 @@ Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic character.\n"))) -(define summoning-bell-commands - (list - (direct-command "ring" 'cmd-ring))) -(define summoning-bell-commands* - (append summoning-bell-commands - thing-commands*)) - (define-class () (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)))) @@ -467,9 +452,9 @@ if this room is intended for children or child-like adults." (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)))) @@ -557,16 +542,6 @@ It has some bits of bubble gum stuck to it... yuck." ;;; 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 () ;; 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) - (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