(remove-occupant! (wrap-apply gameobj-remove-occupant!))
(set-loc! (wrap-apply gameobj-set-loc!))
(get-name (wrap-apply gameobj-get-name))
- (get-desc (wrap-apply gameobj-get-desc))))
+ (get-desc (wrap-apply gameobj-get-desc))
+ (goes-by (wrap-apply gameobj-goes-by))))
;;; *all* game components that talk to players should somehow
;;; derive from this class.
#:getter gameobj-gm)
;; a name to be known by
(name #:init-keyword #:name
- #:accessor gameobj-name)
+ #:init-value #f)
+ (goes-by #:init-keyword #:goes-by
+ #:init-value #f)
(desc #:init-value ""
#:init-keyword #:desc)
#:getter gameobj-name-f
#:init-value (wrap gameobj-simple-name-f))
- ;; Name aliases
- (aliases #:init-keyword #:aliases
- #:init-value '())
-
;; Commands we can handle
(commands #:init-value '())
"Your most basic game object init procedure. Does nothing."
#f)
+(define (gameobj-goes-by gameobj)
+ "Find the name we go by. Defaults to #:name if nothing else provided."
+ (cond ((slot-ref gameobj 'goes-by) =>
+ identity)
+ ((slot-ref gameobj 'name) =>
+ (lambda (name)
+ (list name)))
+ (else '())))
+
(define (val-or-run val-or-proc)
"Evaluate if a procedure, or just return otherwise"
(if (procedure? val-or-proc)
(define filtered-commands
(filter-commands (val-or-run (slot-ref actor 'commands))
verb))
- (<-reply actor message #:commands filtered-commands))
+ (<-reply actor message
+ #:commands filtered-commands
+ #:goes-by (gameobj-goes-by actor)))
(define-mhandler (gameobj-get-container-commands actor message verb)
(define filtered-commands
(define (gameobj-simple-name-f gameobj)
"Simplest version: return ourselves for our name."
(gameobj-name gameobj))
-
-
(define (cmatch-direct-obj-greedy phrase)
;; Turns out this uses the same semantics as splitting verb/rest
- (match (split-verb-and-rest string)
+ (match (split-verb-and-rest phrase)
((direct-obj . rest)
(list #:direct-obj direct-obj
#:rest rest))
(define player-actions
(build-actions
- (init (wrap-apply player-init!))
+ (init (wrap-apply player-init))
(handle-input (wrap-apply player-handle-input))
- (tell (wrap-apply player-tell))
- ;; @@: We really need to unify / make sensible this look stuff
- (look-room (wrap-apply player-look-room))))
+ (tell (wrap-apply player-tell))))
(define player-actions*
(append player-actions
;;; player message handlers
-(define-mhandler (player-init! player message)
- (player-look-around player))
+(define-mhandler (player-init player message)
+ ;; Look around the room we're in
+ (<- player (gameobj-loc player) 'look-room))
(define-mhandler (player-handle-input player message input)
(<- player (gameobj-gm player) 'write-home
#:text text))
-(define-mhandler (player-look-room player message)
- (player-look-around player))
-
-
-;;; player methods
-
-(define (player-look-around player)
- (define room-name
- (message-ref
- (<-wait player (gameobj-loc player) 'get-name)
- 'val))
- (define room-desc
- (message-ref
- (<-wait player (gameobj-loc player) 'get-desc)
- 'val))
- (define message-text
- (format #f "**~a**\n~a\n" room-name room-desc))
-
- (<- player (gameobj-gm player) 'write-home #:text message-text))
-
;;; Command handling
;;; ================
(define co-occupant-commands
;; TODO: Switch this to a fold. Ignore a result if it
;; returns false for in the command response
- (map
- (lambda (co-occupant)
- (let ((result (<-wait player co-occupant 'get-commands
- #:verb verb)))
- (list
- (message-ref result 'commands)
- (message-ref result 'goes-by)
- co-occupant)))
+ (fold
+ (lambda (co-occupant prev)
+ (display "pre-message\n")
+ (let* ((result (<-wait player co-occupant 'get-commands
+ #:verb verb))
+ (commands (message-ref result 'commands))
+ (goes-by (message-ref result 'goes-by)))
+ (display "post-message\n")
+ (append
+ (map (lambda (command)
+ (list command goes-by co-occupant))
+ commands)
+ prev)))
+ '()
co-occupants))
;; Append our own command handlers
(sort
actors-and-commands
(lambda (x y)
- (> (command-priority (car (pk 'x x)))
- (command-priority (car (pk 'y y)))))))
+ (pk 'x x)
+ (pk 'y y)
+ (> (command-priority (car x))
+ (command-priority (car y))))))
(define (find-command-winner sorted-candidates line)
(wire-exits! (wrap-apply room-wire-exits!))
(cmd-go (wrap-apply room-cmd-go))
(cmd-go-where (wrap-apply room-cmd-go-where))
- (cmd-look-room (wrap-apply room-cmd-look-room))))
+ (look-room (wrap-apply room-look-room))
+ ;; in this case the command is the same version as the normal
+ ;; look-room version
+ (cmd-look-room (wrap-apply room-look-room))))
(define room-actions*
(append room-actions gameobj-actions))
(room-exits room)))
(cond
(exit
+ ;; Set the player's new location
(<-wait room (message-from message) 'set-loc!
#:loc (slot-ref exit 'to-address))
- (<- room (message-from message) 'look-room))
+ ;; Have the new room update the player to the new location
+ (<- room (slot-ref exit 'to-address) 'look-room
+ #:to-id (message-from message)))
(else
(<- room (message-from message) 'tell
#:text "You don't see any way to go there.\n"))))
(<- room (message-from message) 'tell
#:text "Go where?\n"))
-(define-mhandler (room-cmd-look-room room message)
- (<- room (message-from message) 'look-room))
+;;; look commands
+
+(define (room-player-looks-around room player-id)
+ "Handle looking around the room"
+ (define room-text
+ (format #f "**~a**\n~a\n"
+ (slot-ref room 'name)
+ (slot-ref room 'desc)))
+ (<- room player-id 'tell
+ #:text room-text))
+
+(define-mhandler (room-look-room room message)
+ "Command: Player asks to look around the room"
+ (room-player-looks-around
+ room
+ ;; Either send it to the #:to-id of the message, or to the
+ ;; sender of the message
+ (message-ref message 'to-id
+ (message-from message))))
;;; ----------
(define-class <fridge> (<gameobj>)
- #:name "fridge"
- #:desc "The refrigerator is humming. To you? To itself?
-Only the universe knows.")
+ (name #:init-value "fridge")
+ (desc #:init-value "The refrigerator is humming. To you? To itself?
+Only the universe knows."))
;;; The typewriter
(define (type-thing actor message type-text)
(<- actor (message-from message) 'tell
#:text
- (format #f "You type out a note.\nThe note says: ~s"
+ (format #f "You type out a note.\nThe note says: ~s\n"
type-text)))
(define-mhandler (typewriter-cmd-type-something
projects / mudsync.git / commitdiff