X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fcontainer.scm;fp=mudsync%2Fcontainer.scm;h=46a52e5a6a9db261681d16a05b83c89b5eb25dad;hp=0000000000000000000000000000000000000000;hb=76ece1325111d6736003c3a3c7b6383f07478d3e;hpb=cc0dc06ed2164992bf9e37917db628fcf82e6d14 diff --git a/mudsync/container.scm b/mudsync/container.scm new file mode 100644 index 0000000..46a52e5 --- /dev/null +++ b/mudsync/container.scm @@ -0,0 +1,169 @@ +;;; Mudsync --- Live hackable MUD +;;; Copyright © 2016 Christopher Allan Webber +;;; +;;; This file is part of Mudsync. +;;; +;;; Mudsync is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; Mudsync is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Mudsync. If not, see . + +;;; Containers + +(define-module (mudsync container) + #:use-module (8sync) + #:use-module (oop goops) + #:use-module (mudsync gameobj) + #:use-module (mudsync utils) + #:use-module (ice-9 control) + #:export ( + cmd-take-from cmd-put-in)) + +(define-actor () + ((cmd-take-from cmd-take-from) + (cmd-put-in cmd-put-in)) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting take-what) + (take-from-me? #:init-value #t + #:init-keyword #:take-from-me?) + ;; Can be a boolean or a procedure accepting + ;; (gameobj whos-acting put-what) + (put-in-me? #:init-value #t + #:init-keyword #:put-in-me?)) + +;; @@: Moving this to a container subclass/mixin could allow a lot more +;; customization of take out / put in phrases +(define* (cmd-take-from gameobj message + #:key direct-obj indir-obj preposition + (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) + (define goes-by (mbody-val (<-wait occupant 'goes-by))) + (when (ci-member direct-obj goes-by) + (return occupant))) + (gameobj-occupants gameobj)) + ;; nothing found + #f))) + (define (this-thing-name) + (mbody-val (<-wait this-thing 'get-name))) + (define (should-take-from-me) + (and this-thing + (slot-ref-maybe-runcheck gameobj 'take-from-me? player this-thing))) + (define (default-objection) + `("Unfortunately, it doesn't seem like you can take " + ,(this-thing-name) " " ,preposition " " ,our-name ".")) + + (define (this-thing-objection) + (mbody-receive (_ taken-ok? #:key why-not) ; does the object object to being removed? + (<-wait this-thing '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 + ;; Unfortunately this does leak information about what is contained + ;; by us. Maybe not what's wanted in all circumstances. + ((not this-thing) + (<- player 'tell + #:text `("You don't see any such " ,direct-obj " to take " + ,preposition " " ,our-name "."))) + ;; A particular objection to taking this thing. + ;; We should allow customizing the reason here, which could be + ;; provided by the 'ok-to-be-taken-from? slot. + ((not (should-take-from-me)) + (<- player 'tell + #:text (default-objection))) + ;; the thing we wsant to take itself has objected... + ((this-thing-objection) => + (lambda (objection) + (<- player 'tell + #:text objection))) + ;; looks like we can take it + (else + ;; 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 player) + (<- player 'tell + #:text `("You take " ,(this-thing-name) " from " + ,our-name ".")) + (<- player-loc 'tell-room + #:text `(,player-name " takes " ,(this-thing-name) " from " + ,our-name ".") + #:exclude player)))) + +(define* (cmd-put-in gameobj message + #:key direct-obj indir-obj preposition + (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) + (define goes-by (mbody-val (<-wait occupant 'goes-by))) + (when (ci-member direct-obj goes-by) + (return occupant))) + (mbody-val (<-wait player 'get-occupants))) + ;; nothing found + #f))) + (define (this-thing-name) + (mbody-val (<-wait this-thing 'get-name))) + (define (should-put-in-me) + (and this-thing + (slot-ref-maybe-runcheck gameobj 'put-in-me? player this-thing))) + (define (default-objection) + `("As much as you'd like to, it doesn't seem like you can put " + ,(this-thing-name) " " ,preposition " " ,our-name ".")) + (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? + ((not this-thing) + (<- player 'tell + #:text `("You don't seem to have any such " ,direct-obj " to put " + ,preposition " " ,our-name "."))) + + ((or (not (should-put-in-me))) + (<- player 'tell + #:text (default-objection))) + ;; the thing we wsant to take itself has objected... + ((this-thing-objection) => + (lambda (objection) + (<- player 'tell + #:text objection))) + ;; looks like we can take it + (else + ;; 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 `("You put " ,(this-thing-name) " " ,preposition " " + ,our-name ".")) + (<- player-loc 'tell-room + #:text `(,player-name " puts " ,(this-thing-name) " " ,preposition " " + ,our-name ".") + #:exclude player))))