(define-module (mudsync thing)
#:use-module (mudsync command)
#:use-module (mudsync gameobj)
- #:use-module (8sync systems actors)
+ #:use-module (8sync actors)
#:use-module (8sync agenda)
#:use-module (oop goops)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (<thing>
thing-commands
+ thing-commands*
thing-contained-commands
- thing-actions))
+ thing-contained-commands*))
(define thing-commands
(list
(direct-command "take" 'cmd-take)))
-;;; Are these kinds of things useful?
-;; ;; Doesn't inherit anything (gameobj has no commands)
-;; ;; so it's an alias.
-;; (define thing-commands* thing-commands)
+;; Doesn't inherit anything (gameobj has no commands)
+;; so it's an alias.
+(define thing-commands* thing-commands)
(define thing-contained-commands
(list
- (empty-command "drop" 'cmd-drop)))
+ (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)
-
-(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*))
+;; Doesn't inherit anything (gameobj has no contained-commands)
+;; so it's an alias.
+(define thing-contained-commands* thing-contained-commands)
(define-class <thing> (<gameobj>)
;; Can be a boolean or a procedure accepting two arguments
#: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
+ (build-actions
+ (cmd-take thing-cmd-take)
+ (cmd-drop thing-cmd-drop))))
-(define-mhandler (thing-cmd-take thing message direct-obj)
+(define* (thing-cmd-take thing message #:key direct-obj)
(define player (message-from message))
(define player-name
- (message-ref
- (<-wait thing player 'get-name)
- 'val))
+ (msg-val (<-wait player 'get-name)))
+ (define player-loc
+ (msg-val (<-wait player 'get-loc)))
(define thing-name (slot-ref thing 'name))
(define should-take
(slot-ref-maybe-runcheck thing 'takeable player))
;; Set the location to whoever's picking us up
(begin
(gameobj-set-loc! thing player)
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "You pick up ~a.\n"
thing-name))
- (<- thing (gameobj-loc thing) 'tell-room
+ (<- player-loc 'tell-room
#:text (format #f "~a picks up ~a.\n"
player-name
thing-name)
#:exclude player))
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "It doesn't seem like you can pick up ~a.\n"
thing-name))))
-(define-mhandler (thing-cmd-drop thing message direct-obj)
+(define* (thing-cmd-drop thing message #:key direct-obj)
(define player (message-from message))
(define player-name
- (message-ref
- (<-wait thing player 'get-name)
- 'val))
+ (msg-val (<-wait player 'get-name)))
(define player-loc
- (message-ref
- (<-wait thing player 'get-loc)
- 'val))
+ (msg-val (<-wait player 'get-loc)))
(define thing-name (slot-ref thing 'name))
(define should-drop
(slot-ref-maybe-runcheck thing 'dropable player))
;; Set the location to whoever's picking us up's location
(begin
(gameobj-set-loc! thing player-loc)
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "You drop ~a.\n"
thing-name))
- (<- thing player-loc 'tell-room
+ (<- player-loc 'tell-room
#:text (format #f "~a drops ~a.\n"
player-name
thing-name)
#:exclude player))
- (<- thing player 'tell
+ (<- player 'tell
#:text (format #f "It doesn't seem like you can drop ~a.\n"
thing-name))))