From 566bf50b08106fe68270c79420886a546666e786 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Wed, 25 Jan 2017 21:01:06 -0600 Subject: [PATCH] Remove thing and fold into gameobj. Allow to mark obvious / not obvious commands --- Makefile.am | 1 - mudsync.scm | 3 +- mudsync/command.scm | 56 +++++++++++++++--------- mudsync/gameobj.scm | 102 +++++++++++++++++++++++++++++++++++++++++-- mudsync/thing.scm | 102 ------------------------------------------- worlds/bricabrac.scm | 32 +++++++------- 6 files changed, 152 insertions(+), 144 deletions(-) delete mode 100644 mudsync/thing.scm diff --git a/Makefile.am b/Makefile.am index b732060..d4885f4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -53,7 +53,6 @@ SOURCES = \ mudsync/player.scm \ mudsync/room.scm \ mudsync/run-game.scm \ - mudsync/thing.scm \ mudsync/package-config.scm \ mudsync/contrib/mime-types.scm \ mudsync.scm diff --git a/mudsync.scm b/mudsync.scm index 15f4c86..810f6d4 100644 --- a/mudsync.scm +++ b/mudsync.scm @@ -35,8 +35,7 @@ command player room - run-game - thing)) + run-game)) (for-each (let ((i (module-public-interface (current-module)))) (lambda (m) diff --git a/mudsync/command.scm b/mudsync/command.scm index a79f50d..6314c70 100644 --- a/mudsync/command.scm +++ b/mudsync/command.scm @@ -64,13 +64,14 @@ ;; (define command-priority sixth) (define-record-type - (make-command verbs matcher should-handle action priority) + (make-command verbs matcher should-handle action priority obvious?) command? (verbs command-verbs) (matcher command-matcher) (should-handle command-should-handle) (action command-action) - (priority command-priority)) + (priority command-priority) + (obvious? command-obvious?)) (define-syntax %build-command (syntax-rules () @@ -93,7 +94,7 @@ (append (%build-command verb-or-verbs cmd-defs ...) ...))) -(define (direct-command verbs action) +(define* (direct-command verbs action #:key (obvious? #t)) (make-command verbs cmatch-direct-obj ;; @@: Should we allow fancier matching than this? @@ -101,19 +102,22 @@ (lambda* (goes-by #:key direct-obj) (member direct-obj goes-by)) action - %default-priority)) + %default-priority + obvious?)) -(define (loose-direct-command verbs action) +(define* (loose-direct-command verbs action #:key (obvious? #t)) (make-command verbs cmatch-direct-obj ;; @@: Should we allow fancier matching than this? ;; Let the actor itself pass along this whole method? (const #t) action - %default-priority)) + %default-priority + obvious?)) -(define* (prep-indir-command verbs action #:optional prepositions) +(define* (prep-indir-command verbs action #:optional prepositions + #:key (obvious? #t)) (make-command verbs cmatch-indir-obj (lambda* (goes-by #:key direct-obj indir-obj preposition) @@ -123,9 +127,11 @@ (member preposition prepositions)) (member indir-obj goes-by))) action - %high-priority)) + %high-priority + obvious?)) -(define* (prep-direct-command verbs action #:optional prepositions) +(define* (prep-direct-command verbs action #:optional prepositions + #:key (obvious? #t)) (make-command verbs cmatch-indir-obj (lambda* (goes-by #:key direct-obj indir-obj preposition) @@ -135,41 +141,51 @@ (member preposition prepositions)) (member direct-obj goes-by))) action - %high-priority)) + %high-priority + obvious?)) -(define* (loose-prep-command verbs action #:optional prepositions) +(define* (loose-prep-command verbs action #:optional prepositions + #:key (obvious? #t)) (make-command verbs cmatch-indir-obj (const #t) action - %high-priority)) + %high-priority + obvious?)) -(define (empty-command verbs action) +(define* (empty-command verbs action + #:key (obvious? #t)) (make-command verbs cmatch-empty (const #t) action - %low-priority)) + %low-priority + obvious?)) -(define (greedy-command verbs action) +(define* (greedy-command verbs action + #:key (obvious? #t)) (make-command verbs cmatch-greedy (const #t) action - %low-priority)) + %low-priority + obvious?)) -(define (direct-greedy-command verbs action) +(define* (direct-greedy-command verbs action + #:key (obvious? #t)) "greedy commands but which match the direct object" (make-command verbs cmatch-direct-obj-greedy (lambda* (goes-by #:key direct-obj rest) (member direct-obj goes-by)) action - %low-priority)) + %low-priority + obvious?)) ;; @@: We should probably ONLY allow these to go to users! (define* (custom-command verbs matcher should-handle action - #:optional (priority %default-priority)) + #:optional (priority %default-priority) + #:key (obvious? #t)) "Full-grained customizable command." - (make-command verbs matcher should-handle action priority)) + (make-command verbs matcher should-handle action priority obvious?)) diff --git a/mudsync/gameobj.scm b/mudsync/gameobj.scm index 0085852..7abb448 100644 --- a/mudsync/gameobj.scm +++ b/mudsync/gameobj.scm @@ -62,6 +62,7 @@ ;; game master id (gm #:init-keyword #:gm #:getter gameobj-gm) + ;; a name to be known by (name #:init-keyword #:name #:init-value #f) @@ -73,7 +74,8 @@ ;; Commands we can handle (commands #:allocation #:each-subclass - #:init-thunk (build-commands)) + #:init-thunk (build-commands + ("take" ((direct-command cmd-take #:obvious? #f))))) ;; Commands we can handle by being something's container (container-commands #:allocation #:each-subclass @@ -81,7 +83,9 @@ ;; Commands we can handle by being contained by something else (contained-commands #:allocation #:each-subclass - #:init-thunk (build-commands)) + #:init-thunk + (build-commands + ("drop" ((direct-command cmd-drop #:obvious? #f))))) ;; Most objects are generally visible by default (generally-visible #:init-value #t @@ -91,6 +95,16 @@ (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) + + ;; TODO: Remove this and use actor-alive? instead. ;; Set this on self-destruct ;; (checked by some "long running" game routines) (destructed #:init-value #f) @@ -106,6 +120,7 @@ (get-container-commands gameobj-get-container-commands) ;; Commands for inventory items, etc (occupants of the gameobj commanding) (get-contained-commands gameobj-get-contained-commands) + (get-occupants gameobj-get-occupants) (add-occupant! gameobj-add-occupant!) (remove-occupant! gameobj-remove-occupant!) @@ -118,7 +133,12 @@ (visible-name gameobj-visible-name) (self-destruct gameobj-act-self-destruct) (tell gameobj-tell-no-op) - (assist-replace gameobj-act-assist-replace)))) + (assist-replace gameobj-act-assist-replace) + (ok-to-drop-here? (const #t)) ; ok to drop by default + + ;; Common commands + (cmd-take cmd-take) + (cmd-drop cmd-drop)))) ;;; gameobj message handlers @@ -352,3 +372,79 @@ By default, this is whether or not the generally-visible flag is set." (#f #f) ;; otherwise it's probably an address, return it as-is (_ special-symbol))) + + + +;;; Basic actions +;;; ------------- + +(define* (cmd-take gameobj 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 our-name (slot-ref gameobj 'name)) + (define self-should-take + (slot-ref-maybe-runcheck gameobj 'takeable 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 + (if self-should-take + ;; Set the location to whoever's picking us up + (begin + (gameobj-set-loc! gameobj player) + (<- player 'tell + #:text (format #f "You pick up ~a.\n" + our-name)) + (<- player-loc 'tell-room + #:text (format #f "~a picks up ~a.\n" + player-name + our-name) + #:exclude player)) + (<- player 'tell + #:text (format #f "It doesn't seem like you can take ~a.\n" + our-name)))) + +(define* (cmd-drop gameobj 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 our-name (slot-ref gameobj 'name)) + (define should-drop + (slot-ref-maybe-runcheck gameobj 'dropable player)) + (define (room-objection-to-drop) + (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 + (or why-not + `("You'd love to drop " ,our-name + " but for some reason it doesn't seem like you can" + " do that here."))))) + (cond + ((not player-loc) + (<- player 'tell + #:text `("It doesn't seem like you can drop " ,our-name + " here, because you don't seem to be anywhere?!?"))) + ;; TODO: Let ourselves supply a reason why not. + ((not should-drop) + (<- player 'tell + #:text (format #f "It doesn't seem like you can drop ~a.\n" + our-name))) + ((room-objection-to-drop) + (<- player 'tell + #:text room-objection-to-drop)) + (else + (gameobj-set-loc! gameobj player-loc) + ;; TODO: Allow more flavortext here. + (<- player 'tell + #:text (format #f "You drop ~a.\n" + our-name)) + (<- player-loc 'tell-room + #:text (format #f "~a drops ~a.\n" + player-name + our-name) + #:exclude player)))) 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)))) diff --git a/worlds/bricabrac.scm b/worlds/bricabrac.scm index cf34903..26b4796 100644 --- a/worlds/bricabrac.scm +++ b/worlds/bricabrac.scm @@ -46,7 +46,7 @@ ;;; Some simple object types. ;;; ========================= -(define-class () +(define-class () (read-text #:init-value "All it says is: \"Blah blah blah.\"" #:init-keyword #:read-text) (commands @@ -140,7 +140,7 @@ Alphanumerics, _ and - only, 2-15 characters, starts with an alphabetic character.\n"))) -(define-class () +(define-class () (summons #:init-keyword #:summons) (commands @@ -275,14 +275,14 @@ Ooh, ~a!" (random-choice #:desc "It looks like you could sign this form and set your name.") ('thing:lobby:porcelain-doll - 'room:lobby + 'room:lobby #:generally-visible #f #:name "a creepy porcelain doll" #:desc "It strikes you that while the doll is technically well crafted, it's also the stuff of nightmares." #:goes-by '("porcelain doll" "doll")) ('thing:lobby:1950s-robots - 'room:lobby + 'room:lobby #:generally-visible #f #:name "a set of 1950s robots" #:desc "There's a whole set of these 1950s style robots. @@ -290,7 +290,7 @@ They seem to be stamped out of tin, and have various decorations of levers and buttons and springs. Some of them have wind-up knobs on them." #:goes-by '("robot" "robots" "1950s robot" "1950s robots")) ('thing:lobby:tea-set - 'room:lobby + 'room:lobby #:generally-visible #f #:name "a tea set" #:desc "A complete tea set. Some of the cups are chipped. @@ -298,7 +298,7 @@ You can imagine yourself joining a tea party using this set, around a nice table with some doilies, drinking some Earl Grey tea, hot. Mmmm." #:goes-by '("tea set" "tea")) ('thing:lobby:mustard-pot - 'room:lobby + 'room:lobby #:generally-visible #f #:name "a mustard pot" #:desc '((p "It's a mustard pot. I mean, it's kind of cool, it has a @@ -307,7 +307,7 @@ like this in a museum.") (p "Ha... imagine that... a mustard museum.")) #:goes-by '("mustard pot" "antique mustard pot" "mustard")) ('thing:lobby:head-of-elvis - 'room:lobby + 'room:lobby #:generally-visible #f #:name "the pickled head of Elvis" #:desc '((p "It's a jar full of some briny-looking liquid and... @@ -321,7 +321,7 @@ everything you read.")) #:goes-by '("pickled head of elvis" "pickled head of Elvis" "elvis" "Elvis" "head" "pickled head")) ('thing:lobby:circuitboard-of-evlis - 'room:lobby + 'room:lobby #:generally-visible #f #:name "the pickled circuitboard of Evlis" #:desc '((p "It's a circuitboard from a Lisp Machine called EVLIS. @@ -335,7 +335,7 @@ Too bad...")) "pickled circuitboard of EVLIS" "evlis" "Evlis" "EVLIS" "circuitboard" "pickled circuitboard")) ('thing:lobby:teletype-scroll - 'room:lobby + 'room:lobby #:generally-visible #f #:name "a scroll of teletype" #:desc '((p "This is a scroll of teletype paper. It's a bit old @@ -356,7 +356,7 @@ English language surrounding the word 'free' have lead to a lot of terminology d "scroll of teletype paper holding the software Four Freedoms" "scroll of teletype paper holding the software four freedoms")) ('thing:lobby:orange-cat-phone - 'room:lobby + 'room:lobby #:generally-visible #f #:name "a telephone shaped like an orange cartoon cat" #:desc "It's made out of a cheap plastic, and it's very orange. @@ -420,12 +420,12 @@ if this room is intended for children or child-like adults." #:name "east" #:to 'room:grand-hallway))) ('thing:playroom:cubey - 'room:playroom + 'room:playroom #:name "cubey" #:takeable #t #:desc " It's a little foam cube with googly eyes on it. So cute!") ('thing:cuddles-plushie - 'room:playroom + 'room:playroom #:name "a cuddles plushie" #:goes-by '("plushie" "cuddles plushie" "cuddles") #:takeable #t @@ -527,7 +527,7 @@ seat in the room, though." #:catchphrases prefect-quotes) ('thing:smoking-parlor:no-smoking-sign - 'room:smoking-parlor + 'room:smoking-parlor #:generally-visible #f #:name "No Smoking Sign" #:desc "This sign says \"No Smoking\" in big, red letters. @@ -542,7 +542,7 @@ It has some bits of bubble gum stuck to it... yuck." ;;; Breakroom ;;; --------- -(define-class () +(define-class () ;; The desk clerk has three states: ;; - on-duty: Arrived, and waiting for instructions (and losing patience ;; gradually) @@ -783,13 +783,13 @@ the scenery tapers off nothingness. But that can't be right, can it?" hotel insignia. She appears to be rather exhausted." #:goes-by '("hotel desk clerk" "clerk" "desk clerk")) ('thing:break-room:void - 'room:break-room + 'room:break-room #:generally-visible #f #:name "The Void" #:desc "As you stare into the void, the void stares back into you." #:goes-by '("void" "abyss" "nothingness" "scenery")) ('thing:break-room:fence - 'room:break-room + 'room:break-room #:generally-visible #f #:name "break room cage" #:desc "It's a mostly-cubical wire mesh surrounding the break area. -- 2.31.1