From: Christopher Allan Webber Date: Thu, 5 May 2016 03:06:30 +0000 (-0500) Subject: Can FINALLY interact with objects! Woohoo! X-Git-Tag: fosdem-2017~181 X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=d539213774955a5593ec760f06022aeecf4e1abc Can FINALLY interact with objects! Woohoo! --- diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index a418cf0..bb4c852 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -51,7 +51,8 @@ (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. @@ -71,7 +72,9 @@ #: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) @@ -81,10 +84,6 @@ #: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 '()) @@ -111,6 +110,15 @@ "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) @@ -128,7 +136,9 @@ (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 @@ -170,5 +180,3 @@ (define (gameobj-simple-name-f gameobj) "Simplest version: return ourselves for our name." (gameobj-name gameobj)) - - diff --git a/mudsync/parser.scm b/mudsync/parser.scm index 3d84195..e9c4096 100644 --- a/mudsync/parser.scm +++ b/mudsync/parser.scm @@ -93,7 +93,7 @@ (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)) diff --git a/mudsync/player.scm b/mudsync/player.scm index bf19a16..00b28ed 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -37,11 +37,9 @@ (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 @@ -68,8 +66,9 @@ ;;; 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) @@ -95,26 +94,6 @@ (<- 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 ;;; ================ @@ -156,14 +135,20 @@ (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 @@ -188,8 +173,10 @@ (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) diff --git a/mudsync/room.scm b/mudsync/room.scm index 56c5a59..aee0636 100644 --- a/mudsync/room.scm +++ b/mudsync/room.scm @@ -79,7 +79,10 @@ (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)) @@ -128,9 +131,12 @@ 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 "You don't see any way to go there.\n")))) @@ -139,5 +145,22 @@ claim to point to." (<- 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)))) diff --git a/worlds/goblin-hq.scm b/worlds/goblin-hq.scm index 34b430d..bd79b80 100644 --- a/worlds/goblin-hq.scm +++ b/worlds/goblin-hq.scm @@ -28,9 +28,9 @@ ;;; ---------- (define-class () - #: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 @@ -69,7 +69,7 @@ You type some gibberish on the typewriter.\n")) (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