X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Froom.scm;h=6baea54ce99daef1d83e8b0440de2fb0ef8a4f5e;hp=5c93be3d5b615e666d789177b2cf1c4001b0a7e3;hb=29f902827724fd50b512c60916a16850367f6046;hpb=4738c5ae39e26b65cdba3bec005bfe034c4ea2c2 diff --git a/mudsync/room.scm b/mudsync/room.scm index 5c93be3..6baea54 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -23,6 +23,7 @@ #:use-module (8sync agenda) #:use-module (oop goops) #:use-module (srfi srfi-1) + #:use-module (ice-9 control) #:export ( room-actions room-actions* @@ -69,7 +70,30 @@ (list (loose-direct-command "look" 'cmd-look-at) (empty-command "look" 'cmd-look-room) - (loose-direct-command "go" 'cmd-go))) + (empty-command "go" 'cmd-go-where) + (loose-direct-command "go" 'cmd-go) + (greedy-command "say" 'cmd-say))) + +(define room-actions + (build-actions + ;; desc == description + (init (wrap-apply room-init)) + (wire-exits! (wrap-apply room-wire-exits!)) + (cmd-go (wrap-apply room-cmd-go)) + (cmd-go-where (wrap-apply room-cmd-go-where)) + (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)))) + +(define room-actions* + (append room-actions gameobj-actions)) + +(define room-action-dispatch + (simple-dispatcher room-actions*)) ;; TODO: Subclass from container? (define-class () @@ -79,35 +103,24 @@ #:getter room-exits) (container-commands - #:init-value %room-contain-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))) +(define (room-init room message) + (room-wire-exits! room)) -(define room-actions - (build-actions - ;; desc == description - (wire-exits! (wrap-apply room-wire-exits!)) - (cmd-go (wrap-apply room-cmd-go)))) - -(define room-actions* - (append room-actions gameobj-actions)) - -(define room-action-dispatch - (simple-dispatcher room-actions*)) - - -(define (room-wire-exits! room message) +(define (room-wire-exits! room) "Actually hook up the rooms' exit addresses to the rooms they claim to point to." (for-each (lambda (exit) (define new-exit (message-ref - (<-wait room (gameobj-gm room) 'lookup-room + (<-wait room (gameobj-gm room) 'lookup-special #:symbol (slot-ref exit 'to-symbol)) 'room-id)) @@ -123,9 +136,155 @@ claim to point to." (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 "I don't know where that is?\n")))) + #:text "You don't see any way to go there.\n")))) + +(define-mhandler (room-cmd-go-where room message) + (<- room (message-from message) 'tell + #:text "Go where?\n")) + +;;; look commands + +(define (list-words-as-string words) + "A little utility for listing a bunch of words in an English-style list" + ;; TODO: This could be made faster by traversing the O(n) + ;; list once, not twice + (let ((word-length (length words))) + (cond + ((eqv? word-length 0) "") + ((eqv? word-length 1) (car words)) + (else + ;; TODO: and this is NOT efficient + (string-append + (string-join + (drop-right words 1) + ", ") + " and " + (last words)))))) + +(define (room-player-looks-around room player-id) + "Handle looking around the room" + ;; Get the room text + (define room-text + (format #f "**~a**\n~a\n" + (slot-ref room 'name) + (slot-ref room 'desc))) + + ;; Get a list of other things the player would see in the room + (define occupant-names-all + (map + (lambda (occupant) + (message-ref + (<-wait room occupant 'visible-name + #:whos-looking player-id) + 'text)) + (remove + (lambda (x) (equal? x player-id)) + (hash-map->list (lambda (x _) x) + (slot-ref room 'occupants))))) + + ;; Strip out the #f responses (these aren't listed because they lack a name + ;; or they aren't "obviously visible" to the player) + (define occupant-names-filtered + (filter identity occupant-names-all)) + + (define occupant-names-string + (if (eq? occupant-names-filtered '()) + #f + (format #f "You see here: ~a.\n" + (list-words-as-string occupant-names-filtered)))) + + (define final-text + (if occupant-names-string + (string-append room-text occupant-names-string) + room-text)) + + (<- room player-id 'tell + #:text final-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 (room-find-thing-called room called-this) + "Find something called CALLED-THIS in the room, if any." + (call/ec + (lambda (return) + (for-each + (lambda (occupant) + (define goes-by + (message-ref (<-wait room occupant 'goes-by) + 'goes-by #f)) + (if (member called-this goes-by) + (return occupant))) + (hash-map->list (lambda (key val) key) + (slot-ref room 'occupants))) + #f))) + +(define %formless-desc + "You don't see anything special about it.") + +(define-mhandler (room-look-at room message direct-obj) + "Look at a specific object in the room." + (define matching-object + (room-find-thing-called room direct-obj)) + + (cond + (matching-object + (let ((obj-desc + (message-ref + (<-wait room matching-object 'get-desc + #:whos-looking (message-from message)) + 'val))) + (if obj-desc + (<- room (message-from message) 'tell + #:text (string-append obj-desc "\n")) + (<- room (message-from message) 'tell + #:text (string-append %formless-desc "\n"))))) + (else + (<- room (message-from message) 'tell + #:text "You don't see that here, so you can't look at it.\n")))) + + +(define* (room-tell-room room text #:key exclude wait) + (define who-to-tell (gameobj-occupants room #:exclude exclude)) + (for-each + (lambda (tell-me) + ;; @@: Does anything really care? + (define deliver-method + (if wait + <-wait + <-)) + (deliver-method room tell-me 'tell + #:text text)) + who-to-tell)) + +(define-mhandler (room-act-tell-room room message text) + "Tell the room some messages." + (define exclude (message-ref message 'exclude #f)) + (define wait-delivery (message-ref message 'wait #f)) + (room-tell-room room text + #:exclude exclude + #:wait wait-delivery)) + +(define-mhandler (room-cmd-say room message phrase) + "Command: Say something to room participants." + (define player-name + (message-ref (<-wait room (message-from message) + 'get-name) 'val)) + (define message-to-send + (format #f "~a says: ~a\n" player-name phrase)) + (room-tell-room room message-to-send))