From 76ece1325111d6736003c3a3c7b6383f07478d3e Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Sat, 28 Jan 2017 16:40:52 -0600 Subject: [PATCH] Move containers over to their own module. --- Makefile.am | 1 + mudsync/container.scm | 169 ++++++++++++++++++++++++++++++++++++++++++ mudsync/gameobj.scm | 166 +++++------------------------------------ worlds/bricabrac.scm | 9 ++- 4 files changed, 194 insertions(+), 151 deletions(-) create mode 100644 mudsync/container.scm diff --git a/Makefile.am b/Makefile.am index d6b943c..15f8e8d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -46,6 +46,7 @@ godir=$(libdir)/guile/2.0/ccache SOURCES = \ mudsync/command.scm \ + mudsync/container.scm \ mudsync/game-master.scm \ mudsync/gameobj.scm \ mudsync/networking.scm \ 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)))) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 55b76bb..64c79f1 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -47,7 +47,7 @@ ;; Some of the more common commands cmd-take cmd-drop - cmd-take-from cmd-put-in)) + cmd-take-from-no-op cmd-put-in-no-op)) ;;; Gameobj ;;; ======= @@ -113,14 +113,6 @@ ;; (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 @@ -159,9 +151,9 @@ ;; Common commands (cmd-take cmd-take) - (cmd-take-from cmd-take-from) - (cmd-put-in cmd-put-in) - (cmd-drop cmd-drop)))) + (cmd-drop cmd-drop) + (cmd-take-from cmd-take-from-no-op) + (cmd-put-in cmd-put-in-no-op)))) ;;; gameobj message handlers @@ -491,138 +483,18 @@ By default, this is whether or not the generally-visible flag is set." our-name) #:exclude player)))) -;; @@: 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 - ;; Wait, aren't we going to check (should-take-from-me) later? - ;; Well yes, but this checks if there's a #f as the value, which - ;; is a much clearer indication that this doesn't take *anything*. - ((not (slot-ref gameobj 'take-from-me?)) - (<- player 'tell - #:text `("It's not really clear how to take something " ,preposition - " " ,our-name "."))) - ;; 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 from " - ,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)))) +(define* (cmd-take-from-no-op gameobj message + #:key direct-obj indir-obj preposition + (player (message-from message))) + (<- player 'tell + #:text `("It doesn't seem like you can take anything " + ,preposition " " + ,(slot-ref gameobj 'name) "."))) + +(define* (cmd-put-in-no-op gameobj message + #:key direct-obj indir-obj preposition + (player (message-from message))) + (<- player 'tell + #:text `("It doesn't seem like you can put anything " + ,preposition " " + ,(slot-ref gameobj 'name) "."))) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index 5676c10..5154987 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -19,6 +19,7 @@ ;;; Hotel Bricabrac (use-modules (mudsync) + (mudsync container) (8sync actors) (8sync agenda) (oop goops) @@ -82,9 +83,9 @@ (escape))) (slot-ref gameobj 'proxy-items)) - (cmd-take-from gameobj message - #:direct-obj direct-obj #:indir-obj indir-obj - #:preposition preposition #:player player)))) + (<- player 'tell + #:text `("You don't see any such " ,direct-obj " to take " + ,preposition " " ,(slot-ref gameobj 'name) "."))))) @@ -525,7 +526,7 @@ if this room is intended for children or child-like adults." #:desc " A warm and fuzzy cuddles plushie! It's a cuddlefish!") ('playroom:toy-chest - 'playroom + 'playroom #:name "a toy chest" #:goes-by '("toy chest" "chest") #:desc (lambda (toy-chest whos-looking) -- 2.31.1