From: Christopher Allan Webber Date: Mon, 9 May 2016 15:27:52 +0000 (-0500) Subject: adding and dropping things works X-Git-Tag: fosdem-2017~147 X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=b2f9a911ac1663fda4dc3cf18ade3334c01327b2;p=mudsync.git adding and dropping things works --- diff --git a/mudsync/player.scm b/mudsync/player.scm index d2fc76d..172b810 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -165,8 +165,6 @@ ;; Get all the co-occupants' commands (define co-occupant-commands - ;; TODO: Switch this to a fold. Ignore a result if it - ;; returns false for in the command response (fold (lambda (co-occupant prev) (let* ((result (<-wait player co-occupant 'get-commands @@ -189,7 +187,24 @@ (val-or-run (slot-ref player 'self-commands)))) - ;; TODO: Append our inventory's relevant command handlers + ;; Append our inventory's relevant command handlers + (define inv-items + (gameobj-occupants player)) + (define inv-item-commands + (fold + (lambda (inv-item prev) + (let* ((result (<-wait player inv-item + 'get-contained-commands + #:verb verb)) + (commands (message-ref result 'commands)) + (goes-by (message-ref result 'goes-by))) + (append + (map (lambda (command) + (list command goes-by inv-item)) + commands) + prev))) + '() + inv-items)) ;; Now return a big ol sorted list of ((actor-id . command)) (append @@ -197,7 +212,8 @@ player-loc '()) ; room doesn't go by anything (sort-commands-multi-actors co-occupant-commands) (sort-commands-append-actor our-commands - (actor-id player) '()))) ; nor does player + (actor-id player) '()) ; nor does player + (sort-commands-multi-actors inv-item-commands))) (define (sort-commands-append-actor commands actor-id goes-by) (sort-commands-multi-actors diff --git a/mudsync/thing.scm b/mudsync/thing.scm index 341371f..a3ae6b0 100644 --- a/mudsync/thing.scm +++ b/mudsync/thing.scm @@ -28,25 +28,27 @@ #:use-module (ice-9 format) #:export ( thing-commands + thing-commands* thing-contained-commands - thing-actions)) + thing-contained-commands* + thing-actions + thing-actions*)) (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) +;; 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 @@ -83,6 +85,10 @@ (message-ref (<-wait thing player 'get-name) 'val)) + (define player-loc + (message-ref + (<-wait thing player 'get-loc) + 'val)) (define thing-name (slot-ref thing 'name)) (define should-take (slot-ref-maybe-runcheck thing 'takeable player)) @@ -93,7 +99,7 @@ (<- thing player 'tell #:text (format #f "You pick up ~a.\n" thing-name)) - (<- thing (gameobj-loc thing) 'tell-room + (<- thing player-loc 'tell-room #:text (format #f "~a picks up ~a.\n" player-name thing-name) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 7679735..6be5b1a 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -47,18 +47,27 @@ (define readable-commands (list (direct-command "read" 'cmd-read))) + +(define readable-commands* + (append readable-commands + thing-commands)) + (define readable-actions (build-actions (cmd-read (wrap-apply readable-cmd-read)))) -(define-class () +(define readable-actions* + (append readable-actions + thing-actions*)) + +(define-class () (read-text #:init-value "All it says is: \"Blah blah blah.\"" #:init-keyword #:read-text) (commands - #:init-value readable-commands) + #:init-value readable-commands*) (message-handler #:init-value - (simple-dispatcher (append gameobj-actions readable-actions)))) + (simple-dispatcher readable-actions*))) (define (readable-cmd-read actor message) (<- actor (message-from message) 'tell