X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fthing.scm;fp=mudsync%2Fthing.scm;h=0000000000000000000000000000000000000000;hp=a964c50e56aea0cc5233539ce3418d8ae6fdfa3f;hb=566bf50b08106fe68270c79420886a546666e786;hpb=792da4a3c180c3fdb1797e3a5c2d4bca6f40b42d diff --git a/mudsync/thing.scm b/mudsync/thing.scm deleted file mode 100644 index a964c50..0000000 --- a/mudsync/thing.scm +++ /dev/null @@ -1,102 +0,0 @@ -;;; 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 . - -;;; Common "things" and stuff you can do with things. - -(define-module (mudsync thing) - #:use-module (mudsync command) - #:use-module (mudsync gameobj) - #:use-module (8sync actors) - #:use-module (8sync agenda) - #:use-module (oop goops) - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:export ()) - -(define-class () - ;; 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) - (commands - #:allocation #:each-subclass - #:init-thunk (build-commands - ("take" ((direct-command cmd-take))))) - (contained-commands - #:allocation #:each-subclass - #:init-value (build-commands - ("drop" ((direct-command cmd-drop))))) - (actions #:allocation #:each-subclass - #:init-thunk - (build-actions - (cmd-take thing-cmd-take) - (cmd-drop thing-cmd-drop)))) - -(define* (thing-cmd-take thing message #:key direct-obj) - (define player (message-from message)) - (define player-name - (mbody-val (<-wait player 'get-name))) - (define player-loc - (mbody-val (<-wait player 'get-loc))) - (define thing-name (slot-ref thing 'name)) - (define should-take - (slot-ref-maybe-runcheck thing 'takeable player)) - (if should-take - ;; Set the location to whoever's picking us up - (begin - (gameobj-set-loc! thing player) - (<- player 'tell - #:text (format #f "You pick up ~a.\n" - thing-name)) - (<- player-loc 'tell-room - #:text (format #f "~a picks up ~a.\n" - player-name - thing-name) - #:exclude player)) - (<- player 'tell - #:text (format #f "It doesn't seem like you can pick up ~a.\n" - thing-name)))) - -(define* (thing-cmd-drop thing message #:key direct-obj) - (define player (message-from message)) - (define player-name - (mbody-val (<-wait player 'get-name))) - (define player-loc - (mbody-val (<-wait player 'get-loc))) - (define thing-name (slot-ref thing 'name)) - (define should-drop - (slot-ref-maybe-runcheck thing 'dropable player)) - (if player-loc - ;; Set the location to whoever's picking us up's location - (begin - (gameobj-set-loc! thing player-loc) - (<- player 'tell - #:text (format #f "You drop ~a.\n" - thing-name)) - (<- player-loc 'tell-room - #:text (format #f "~a drops ~a.\n" - player-name - thing-name) - #:exclude player)) - (<- player 'tell - #:text (format #f "It doesn't seem like you can drop ~a.\n" - thing-name))))