From: Christopher Allan Webber Date: Thu, 26 Jan 2017 21:12:00 +0000 (-0600) Subject: Add container ability to gameobjs X-Git-Tag: fosdem-2017~75 X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=commitdiff_plain;h=8268d0f1223f0d4fc77a8aa2b195368d56512ca4 Add container ability to gameobjs --- diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 7abb448..7f2f4e2 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -25,6 +25,7 @@ #:use-module (8sync agenda) #:use-module (8sync rmeta-slot) #:use-module (srfi srfi-1) + #:use-module (ice-9 control) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (oop goops) @@ -75,7 +76,11 @@ ;; Commands we can handle (commands #:allocation #:each-subclass #:init-thunk (build-commands - ("take" ((direct-command cmd-take #:obvious? #f))))) + ("take" ((direct-command cmd-take) + (prep-indir-command cmd-take-from + '("from" "out of")))) + ("put" ((prep-indir-command cmd-put-in + '("in" "inside" "on")))))) ;; Commands we can handle by being something's container (container-commands #:allocation #:each-subclass @@ -95,14 +100,22 @@ (visible-to-player? #:init-value (wrap-apply gameobj-visible-to-player?)) - ;; Can be a boolean or a procedure accepting two arguments - ;; (thing-actor whos-acting) - (takeable #:init-value #f - #:init-keyword #:takeable) - ;; Can be a boolean or a procedure accepting two arguments - ;; (thing-actor whos-dropping) - (dropable #:init-value #t - #:init-keyword #:dropable) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting #:key from) + (take-me? #:init-value #f + #:init-keyword #:take-me?) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting where) + (drop-me? #:init-value #t + #:init-keyword #:drop-me?) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting take-what) + (take-from-me? #:init-value #f + #:init-keyword #:take-from-me?) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting put-what) + (put-in-me? #:init-value #f + #:init-keyword #:put-in-me?) ;; TODO: Remove this and use actor-alive? instead. ;; Set this on self-destruct @@ -134,10 +147,15 @@ (self-destruct gameobj-act-self-destruct) (tell gameobj-tell-no-op) (assist-replace gameobj-act-assist-replace) - (ok-to-drop-here? (const #t)) ; ok to drop by default + (ok-to-drop-here? (lambda (gameobj message . _) + (<-reply message #t))) ; ok to drop by default + (ok-to-be-taken-from? gameobj-ok-to-be-taken-from) + (ok-to-be-put-in? gameobj-ok-to-be-put-in) ;; Common commands (cmd-take cmd-take) + (cmd-take-from cmd-take-from) + (cmd-put-in cmd-put-in) (cmd-drop cmd-drop)))) @@ -256,8 +274,7 @@ Assists in its replacement of occupants if necessary and nothing else." "Get all present occupants of the room." (define occupants (gameobj-occupants actor #:exclude exclude)) - - (<-reply message #:occupants occupants)) + (<-reply message occupants)) (define (gameobj-act-get-loc actor message) (<-reply message (slot-ref actor 'loc))) @@ -281,12 +298,12 @@ Assists in its replacement of occupants if necessary and nothing else." "Action routine to set the location." (gameobj-set-loc! actor loc)) -(define (slot-ref-maybe-runcheck gameobj slot whos-asking) +(define (slot-ref-maybe-runcheck gameobj slot whos-asking . other-args) "Do a slot-ref on gameobj, evaluating it including ourselves and whos-asking, and see if we should just return it or run it." (match (slot-ref gameobj slot) ((? procedure? slot-val-proc) - (slot-val-proc gameobj whos-asking)) + (apply slot-val-proc gameobj whos-asking other-args)) (anything-else anything-else))) (define gameobj-get-name (simple-slot-getter 'name)) @@ -340,22 +357,30 @@ By default, this is whether or not the generally-visible flag is set." (define gameobj-tell-no-op (const 'no-op)) -(define (gameobj-replace-data-occupants actor) +(define (gameobj-replace-data-occupants gameobj) "The general purpose list of replacement data" (list #:occupants (hash-map->list (lambda (occupant _) occupant) - (slot-ref actor 'occupants)))) + (slot-ref gameobj 'occupants)))) -(define (gameobj-replace-data* actor) +(define (gameobj-replace-data* gameobj) ;; For now, just call gameobj-replace-data-occupants. ;; But there may be more in the future! - (gameobj-replace-data-occupants actor)) + (gameobj-replace-data-occupants gameobj)) ;; So sad that objects must assist in their replacement ;_; ;; But that's life in a live hacked game! -(define (gameobj-act-assist-replace actor message) +(define (gameobj-act-assist-replace gameobj message) "Vanilla method for assisting in self-replacement for live hacking" (apply <-reply message - (gameobj-replace-data* actor))) + (gameobj-replace-data* gameobj))) + +(define (gameobj-ok-to-be-taken-from gameobj message whos-acting) + (<-reply message (slot-ref-maybe-runcheck gameobj 'take-me? + whos-acting #:from #t))) + +(define (gameobj-ok-to-be-put-in gameobj message whos-acting where) + (<-reply message (slot-ref-maybe-runcheck gameobj 'drop-me? + whos-acting where))) ;;; Utilities every gameobj has @@ -386,7 +411,7 @@ By default, this is whether or not the generally-visible flag is set." (mbody-val (<-wait player 'get-loc))) (define our-name (slot-ref gameobj 'name)) (define self-should-take - (slot-ref-maybe-runcheck gameobj 'takeable player)) + (slot-ref-maybe-runcheck gameobj 'take-me? player)) ;; @@: Is there any reason to allow the room to object in the way ;; that there is for dropping? It doesn't seem like it. ;; TODO: Allow gameobj to customize @@ -414,9 +439,9 @@ By default, this is whether or not the generally-visible flag is set." (mbody-val (<-wait player 'get-loc))) (define our-name (slot-ref gameobj 'name)) (define should-drop - (slot-ref-maybe-runcheck gameobj 'dropable player)) + (slot-ref-maybe-runcheck gameobj 'drop-me? player)) (define (room-objection-to-drop) - (mbody-receive (drop-ok? #:key why-not) ; does the room object to dropping? + (mbody-receive (_ drop-ok? #:key why-not) ; does the room object to dropping? (<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj)) (and (not drop-ok?) ;; Either give the specified reason, or give a boilerplate one @@ -448,3 +473,127 @@ By default, this is whether or not the generally-visible flag is set." player-name our-name) #:exclude player)))) + +(define* (cmd-take-from gameobj message + #:key direct-obj indir-obj preposition) + (define player (message-from message)) + (define player-name + (mbody-val (<-wait player 'get-name))) + (define player-loc + (mbody-val (<-wait player 'get-loc))) + (define our-name (slot-ref gameobj 'name)) + ;; We need to check if we even have such a thing + (define thing-to-take + (call/ec + (lambda (return) + (for-each (lambda (occupant) + (mbody-receive (_ #:key goes-by) + (<-wait occupant 'goes-by) + (when (member direct-obj goes-by) + (return occupant)))) + (gameobj-occupants gameobj)) + ;; nothing found + #f))) + (define (should-take-from-me) + (and thing-to-take + (slot-ref-maybe-runcheck gameobj 'take-from-me? player thing-to-take))) + ;; @@: Right now we give the same response to both something not being + ;; an occupant and to not being permitted to be removed. This isn't + ;; very rich and maybe not as helpful as it could be. Right now I'm + ;; trying to avoid "leaking" information about if an object isn't there. + ;; However maybe by making the different responses as slots which can be + ;; set, this wouldn't be a problem. + (define default-objection + "As much as you'd like to take it, it doesn't seem like you can.") + (define (thing-to-take-objection) + (mbody-receive (_ taken-ok? #:key why-not) ; does the object object to being removed? + (<-wait thing-to-take 'ok-to-be-taken-from? player) ; @@ no need to supply from where + (and (not taken-ok?) + ;; Either give the specified reason, or give a boilerplate one + (or why-not default-objection)))) + (cond + ;; Is it not there, or maybe we won't allow it to be taken? + ((or (not thing-to-take) (not (should-take-from-me))) + (<- (message-from message) 'tell + #:text default-objection)) + ;; the thing we wsant to take itself has objected... + ((thing-to-take-objection) => + (lambda (objection) + (<- (message-from message) 'tell + #:text objection))) + ;; looks like we can take it + (else + (let ((thing-to-take-name + (mbody-val (<-wait thing-to-take 'get-name)))) + ;; Wait to announce to the player just in case settting the location + ;; errors out or something. Maybe it's overthinking things, I dunno. + (<-wait thing-to-take 'set-loc! #:loc player) + (<- player 'tell + #:text `("You take " ,thing-to-take-name " from " + ,our-name ".")) + (<- player-loc 'tell-room + #:text `(,player-name " takes " ,thing-to-take-name " from " + ,our-name ".")))))) + +(define* (cmd-put-in gameobj message + #:key direct-obj indir-obj preposition) + (define player (message-from message)) + (define player-name + (mbody-val (<-wait player 'get-name))) + (define player-loc + (mbody-val (<-wait player 'get-loc))) + (define our-name (slot-ref gameobj 'name)) + ;; We need to check if we even have such a thing + (define this-thing + (call/ec + (lambda (return) + (for-each (lambda (occupant) + (mbody-receive (_ #:key goes-by) + (<-wait occupant 'goes-by) + (when (member direct-obj goes-by) + (return occupant)))) + (pk 'here (mbody-val (<-wait player 'get-occupants)))) + ;; nothing found + #f))) + (define (should-put-in-me) + (and this-thing + (slot-ref-maybe-runcheck gameobj 'put-in-me? player this-thing))) + ;; @@: Right now we give the same response to both something not being + ;; an occupant and to not being permitted to be removed. This isn't + ;; very rich and maybe not as helpful as it could be. Right now I'm + ;; trying to avoid "leaking" information about if an object isn't there. + ;; However maybe by making the different responses as slots which can be + ;; set, this wouldn't be a problem. + (define default-objection + "As much as you'd like to, it doesn't seem like you can put that in there.") + (define (this-thing-objection) + (mbody-receive (_ put-in-ok? #:key why-not) ; does the object object to being moved? + (<-wait this-thing 'ok-to-be-put-in? player (actor-id gameobj)) + (and (not put-in-ok?) + ;; Either give the specified reason, or give a boilerplate one + (or why-not default-objection)))) + (cond + ;; Is it not there, or maybe we won't allow it to be taken? + ((pk '1st (or (not this-thing) (not (should-put-in-me)))) + (<- (message-from message) 'tell + #:text default-objection)) + ;; the thing we wsant to take itself has objected... + ((pk 'objection (this-thing-objection)) => + (lambda (objection) + (<- (message-from message) 'tell + #:text objection))) + ;; looks like we can take it + (else + (let ((this-thing-name + (mbody-val (<-wait this-thing 'get-name)))) + + + ;; Wait to announce to the player just in case settting the location + ;; errors out or something. Maybe it's overthinking things, I dunno. + (<-wait this-thing 'set-loc! #:loc (actor-id gameobj)) + (<- player 'tell + #:text (pk 'txt `("You put " ,this-thing-name " in " + ,our-name "."))) + (<- player-loc 'tell-room + #:text `(,player-name " puts " ,this-thing-name " in " + ,our-name ".")))))) diff --git a/mudsync/player.scm b/mudsync/player.scm index bbd1403..0879300 100644 --- a/mudsync/player.scm +++ b/mudsync/player.scm @@ -160,9 +160,7 @@ (define co-occupants (remove (lambda (x) (equal? x (actor-id player))) - (mbody-receive (_ #:key occupants) - (<-wait player-loc 'get-occupants) - occupants))) + (mbody-val (<-wait player-loc 'get-occupants)))) ;; @@: There's a race condition here if someone leaves the room ;; during this, heh... diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 26b4796..4a92406 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -422,14 +422,31 @@ if this room is intended for children or child-like adults." ('thing:playroom:cubey 'room:playroom #:name "cubey" - #:takeable #t + #:take-me? #t #:desc " It's a little foam cube with googly eyes on it. So cute!") - ('thing:cuddles-plushie + ('thing:playroom:cuddles-plushie 'room:playroom #:name "a cuddles plushie" #:goes-by '("plushie" "cuddles plushie" "cuddles") - #:takeable #t - #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!"))) + #:take-me? #t + #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!") + + ('thing:playroom:toy-chest + 'room:playroom + #:name "a toy chest" + #:goes-by '("toy chest" "chest") + #:desc "A brightly painted wooden chest. The word \"TOYS\" is engraved +on it. What could be inside?" + #:take-from-me? #t + #:put-in-me? #t) + + ;; Things inside the toy chest + ('thing:playroom:toy-chest:rubber-duck + 'thing:playroom:toy-chest + #:name "a rubber duck" + #:goes-by '("rubber duck" "duck") + #:take-me? #t + #:desc "It's a yellow rubber duck with a bright orange beak.")))