(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 ..
gameobj-act-init
gameobj-set-loc!
gameobj-occupants
- gameobj-actions
gameobj-self-destruct
slot-ref-maybe-runcheck
;;; =======
-;;; 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!
;; 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)
;; 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
;; 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)
;;; 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)
(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
#: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
(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>
(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
thing-commands
thing-commands*
thing-contained-commands
- thing-contained-commands*
- thing-actions
- thing-actions*))
+ thing-contained-commands*))
(define thing-commands
(list
;; 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)
#: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))
(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
(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..."
#: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"
#: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
(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
#: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 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
(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
projects / mudsync.git / commitdiff