mudsync/player.scm \
mudsync/room.scm \
mudsync/run-game.scm \
- mudsync/thing.scm \
mudsync/package-config.scm \
mudsync/contrib/mime-types.scm \
mudsync.scm
command
player
room
- run-game
- thing))
+ run-game))
(for-each (let ((i (module-public-interface (current-module))))
(lambda (m)
;; (define command-priority sixth)
(define-record-type <command>
- (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 ()
(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?
(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)
(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)
(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?))
;; game master id
(gm #:init-keyword #:gm
#:getter gameobj-gm)
+
;; a name to be known by
(name #:init-keyword #:name
#:init-value #f)
;; 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
;; 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
(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)
(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!)
(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
(#f #f)
;; otherwise it's probably an address, return it as-is
(_ special-symbol)))
+
+
+\f
+;;; 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))))
+++ /dev/null
-;;; Mudsync --- Live hackable MUD
-;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
-;;;
-;;; 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 <http://www.gnu.org/licenses/>.
-
-;;; 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 (<thing>))
-
-(define-class <thing> (<gameobj>)
- ;; 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))))
;;; Some simple object types.
;;; =========================
-(define-class <readable> (<thing>)
+(define-class <readable> (<gameobj>)
(read-text #:init-value "All it says is: \"Blah blah blah.\""
#:init-keyword #:read-text)
(commands
character.\n")))
-(define-class <summoning-bell> (<thing>)
+(define-class <summoning-bell> (<gameobj>)
(summons #:init-keyword #:summons)
(commands
#:desc "It looks like you could sign this form and set your name.")
('thing:lobby:porcelain-doll
- <thing> 'room:lobby
+ <gameobj> '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
- <thing> 'room:lobby
+ <gameobj> 'room:lobby
#:generally-visible #f
#:name "a set of 1950s robots"
#:desc "There's a whole set of these 1950s style robots.
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
- <thing> 'room:lobby
+ <gameobj> 'room:lobby
#:generally-visible #f
#:name "a tea set"
#:desc "A complete tea set. Some of the cups are chipped.
nice table with some doilies, drinking some Earl Grey tea, hot. Mmmm."
#:goes-by '("tea set" "tea"))
('thing:lobby:mustard-pot
- <thing> 'room:lobby
+ <gameobj> '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
(p "Ha... imagine that... a mustard museum."))
#:goes-by '("mustard pot" "antique mustard pot" "mustard"))
('thing:lobby:head-of-elvis
- <thing> 'room:lobby
+ <gameobj> 'room:lobby
#:generally-visible #f
#:name "the pickled head of Elvis"
#:desc '((p "It's a jar full of some briny-looking liquid and...
#:goes-by '("pickled head of elvis" "pickled head of Elvis"
"elvis" "Elvis" "head" "pickled head"))
('thing:lobby:circuitboard-of-evlis
- <thing> 'room:lobby
+ <gameobj> 'room:lobby
#:generally-visible #f
#:name "the pickled circuitboard of Evlis"
#:desc '((p "It's a circuitboard from a Lisp Machine called EVLIS.
"pickled circuitboard of EVLIS"
"evlis" "Evlis" "EVLIS" "circuitboard" "pickled circuitboard"))
('thing:lobby:teletype-scroll
- <thing> 'room:lobby
+ <gameobj> 'room:lobby
#:generally-visible #f
#:name "a scroll of teletype"
#:desc '((p "This is a scroll of teletype paper. It's a bit old
"scroll of teletype paper holding the software Four Freedoms"
"scroll of teletype paper holding the software four freedoms"))
('thing:lobby:orange-cat-phone
- <thing> 'room:lobby
+ <gameobj> '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.
#:name "east"
#:to 'room:grand-hallway)))
('thing:playroom:cubey
- <thing> 'room:playroom
+ <gameobj> 'room:playroom
#:name "cubey"
#:takeable #t
#:desc " It's a little foam cube with googly eyes on it. So cute!")
('thing:cuddles-plushie
- <thing> 'room:playroom
+ <gameobj> 'room:playroom
#:name "a cuddles plushie"
#:goes-by '("plushie" "cuddles plushie" "cuddles")
#:takeable #t
#:catchphrases prefect-quotes)
('thing:smoking-parlor:no-smoking-sign
- <thing> 'room:smoking-parlor
+ <gameobj> 'room:smoking-parlor
#:generally-visible #f
#:name "No Smoking Sign"
#:desc "This sign says \"No Smoking\" in big, red letters.
;;; Breakroom
;;; ---------
-(define-class <desk-clerk> (<thing>)
+(define-class <desk-clerk> (<gameobj>)
;; The desk clerk has three states:
;; - on-duty: Arrived, and waiting for instructions (and losing patience
;; gradually)
hotel insignia. She appears to be rather exhausted."
#:goes-by '("hotel desk clerk" "clerk" "desk clerk"))
('thing:break-room:void
- <thing> 'room:break-room
+ <gameobj> '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
- <thing> 'room:break-room
+ <gameobj> 'room:break-room
#:generally-visible #f
#:name "break room cage"
#:desc "It's a mostly-cubical wire mesh surrounding the break area.
projects / mudsync.git / commitdiff