1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; This file is part of Mudsync.
6 ;;; Mudsync is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or
9 ;;; (at your option) any later version.
11 ;;; Mudsync is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with Mudsync. If not, see <http://www.gnu.org/licenses/>.
22 (define-module (mudsync gameobj)
23 #:use-module (mudsync command)
24 #:use-module (8sync actors)
25 #:use-module (8sync agenda)
26 #:use-module (8sync rmeta-slot)
27 #:use-module (srfi srfi-1)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 match)
30 #:use-module (oop goops)
41 slot-ref-maybe-runcheck
50 ;;; *all* game components that talk to players should somehow
51 ;;; derive from this class.
52 ;;; And all of them need a GM!
54 (define-class <gameobj> (<actor>)
59 ;; Uses a hash table like a set (values ignored)
60 (occupants #:init-thunk make-hash-table)
63 (gm #:init-keyword #:gm
66 ;; a name to be known by
67 (name #:init-keyword #:name
69 (goes-by #:init-keyword #:goes-by
73 #:init-keyword #:desc)
75 ;; Commands we can handle
76 (commands #:allocation #:each-subclass
77 #:init-thunk (build-commands
78 ("take" ((direct-command cmd-take #:obvious? #f)))))
80 ;; Commands we can handle by being something's container
81 (container-commands #:allocation #:each-subclass
82 #:init-thunk (build-commands))
84 ;; Commands we can handle by being contained by something else
85 (contained-commands #:allocation #:each-subclass
88 ("drop" ((direct-command cmd-drop #:obvious? #f)))))
90 ;; Most objects are generally visible by default
91 (generally-visible #:init-value #t
92 #:init-keyword #:generally-visible)
93 ;; @@: Would be preferable to be using generic methods for this...
94 ;; Hopefully we can port this to Guile 2.2 soon...
96 #:init-value (wrap-apply gameobj-visible-to-player?))
98 ;; Can be a boolean or a procedure accepting two arguments
99 ;; (thing-actor whos-acting)
100 (takeable #:init-value #f
101 #:init-keyword #:takeable)
102 ;; Can be a boolean or a procedure accepting two arguments
103 ;; (thing-actor whos-dropping)
104 (dropable #:init-value #t
105 #:init-keyword #:dropable)
107 ;; TODO: Remove this and use actor-alive? instead.
108 ;; Set this on self-destruct
109 ;; (checked by some "long running" game routines)
110 (destructed #:init-value #f)
112 (actions #:allocation #:each-subclass
113 ;;; Actions supported by all gameobj
116 (init gameobj-act-init)
117 ;; Commands for co-occupants
118 (get-commands gameobj-get-commands)
119 ;; Commands for participants in a room
120 (get-container-commands gameobj-get-container-commands)
121 ;; Commands for inventory items, etc (occupants of the gameobj commanding)
122 (get-contained-commands gameobj-get-contained-commands)
124 (get-occupants gameobj-get-occupants)
125 (add-occupant! gameobj-add-occupant!)
126 (remove-occupant! gameobj-remove-occupant!)
127 (get-loc gameobj-act-get-loc)
128 (set-loc! gameobj-act-set-loc!)
129 (get-name gameobj-get-name)
130 (set-name! gameobj-act-set-name!)
131 (get-desc gameobj-get-desc)
132 (goes-by gameobj-act-goes-by)
133 (visible-name gameobj-visible-name)
134 (self-destruct gameobj-act-self-destruct)
135 (tell gameobj-tell-no-op)
136 (assist-replace gameobj-act-assist-replace)
137 (ok-to-drop-here? (const #t)) ; ok to drop by default
141 (cmd-drop cmd-drop))))
144 ;;; gameobj message handlers
145 ;;; ========================
147 ;; Kind of a useful utility, maybe?
148 (define (simple-slot-getter slot)
149 (lambda (actor message)
150 (<-reply message (slot-ref actor slot))))
152 (define (gameobj-replace-step-occupants actor occupants)
153 ;; Snarf all the occupants!
154 (display "replacing occupant\n")
158 (<-wait occupant 'set-loc!
159 #:loc (actor-id actor)))
162 (define gameobj-replace-steps*
163 (list gameobj-replace-step-occupants))
165 (define (run-replacement actor replaces replace-steps)
167 (mbody-receive (_ #:key occupants)
168 (<-wait replaces 'assist-replace)
170 (lambda (replace-step)
171 (replace-step actor occupants))
174 ;; @@: This could be kind of a messy way of doing gameobj-act-init
175 ;; stuff. If only we had generic methods :(
176 (define* (gameobj-act-init actor message #:key replace)
177 "Your most basic game object init procedure.
178 Assists in its replacement of occupants if necessary and nothing else."
179 (run-replacement actor replace gameobj-replace-steps*))
181 (define (gameobj-goes-by gameobj)
182 "Find the name we go by. Defaults to #:name if nothing else provided."
183 (cond ((slot-ref gameobj 'goes-by) =>
185 ((slot-ref gameobj 'name) =>
190 (define (gameobj-act-goes-by actor message)
191 "Reply to a message requesting what we go by."
192 (<-reply message #:goes-by (gameobj-goes-by actor)))
194 (define (val-or-run val-or-proc)
195 "Evaluate if a procedure, or just return otherwise"
196 (if (procedure? val-or-proc)
200 (define (get-candidate-commands actor rmeta-sym verb)
201 (class-rmeta-ref (class-of actor) rmeta-sym verb
204 (define* (gameobj-get-commands actor message #:key verb)
205 "Get commands a co-occupant of the room might execute for VERB"
206 (define candidate-commands
207 (get-candidate-commands actor 'commands verb))
209 #:commands candidate-commands
210 #:goes-by (gameobj-goes-by actor)))
212 (define* (gameobj-get-container-commands actor message #:key verb)
213 "Get commands as the container / room of message's sender"
214 (define candidate-commands
215 (get-candidate-commands actor 'container-commands verb))
216 (<-reply message #:commands candidate-commands))
218 (define* (gameobj-get-contained-commands actor message #:key verb)
219 "Get commands as being contained (eg inventory) of commanding gameobj"
220 (define candidate-commands
221 (get-candidate-commands actor 'contained-commands verb))
223 #:commands candidate-commands
224 #:goes-by (gameobj-goes-by actor)))
226 (define* (gameobj-add-occupant! actor message #:key who)
227 "Add an actor to our list of present occupants"
228 (hash-set! (slot-ref actor 'occupants)
231 (define* (gameobj-remove-occupant! actor message #:key who)
232 "Remove an occupant from the room."
233 (hash-remove! (slot-ref actor 'occupants) who))
235 (define* (gameobj-occupants gameobj #:key exclude)
237 (lambda (occupant _ prev)
240 ;; Empty list and #f are non-exclusion
243 ;; A list of addresses... since our address object is (annoyingly)
244 ;; currently a simple cons cell...
245 ((exclude-1 ... exclude-rest)
246 (member occupant exclude))
247 ;; Must be an individual address!
248 (_ (equal? occupant exclude))))
251 (cons occupant prev)))
253 (slot-ref gameobj 'occupants)))
255 (define* (gameobj-get-occupants actor message #:key exclude)
256 "Get all present occupants of the room."
258 (gameobj-occupants actor #:exclude exclude))
260 (<-reply message #:occupants occupants))
262 (define (gameobj-act-get-loc actor message)
263 (<-reply message (slot-ref actor 'loc)))
265 (define (gameobj-set-loc! gameobj loc)
266 "Set the location of this object."
267 (define old-loc (gameobj-loc gameobj))
268 (format #t "DEBUG: Location set to ~s for ~s\n"
269 loc (actor-id-actor gameobj))
271 (when (not (equal? old-loc loc))
272 (slot-set! gameobj 'loc loc)
273 ;; Change registation of where we currently are
275 (<-wait old-loc 'remove-occupant! #:who (actor-id gameobj)))
277 (<-wait loc 'add-occupant! #:who (actor-id gameobj)))))
279 ;; @@: Should it really be #:id ? Maybe #:loc-id or #:loc?
280 (define* (gameobj-act-set-loc! actor message #:key loc)
281 "Action routine to set the location."
282 (gameobj-set-loc! actor loc))
284 (define (slot-ref-maybe-runcheck gameobj slot whos-asking)
285 "Do a slot-ref on gameobj, evaluating it including ourselves
286 and whos-asking, and see if we should just return it or run it."
287 (match (slot-ref gameobj slot)
288 ((? procedure? slot-val-proc)
289 (slot-val-proc gameobj whos-asking))
290 (anything-else anything-else)))
292 (define gameobj-get-name (simple-slot-getter 'name))
294 (define* (gameobj-act-set-name! actor message val)
295 (slot-set! actor 'name val))
297 (define* (gameobj-get-desc actor message #:key whos-looking)
299 (match (slot-ref actor 'desc)
300 ((? procedure? desc-proc)
301 (desc-proc actor whos-looking))
303 (<-reply message desc-text))
305 (define (gameobj-visible-to-player? gameobj whos-looking)
306 "Check to see whether we're visible to the player or not.
307 By default, this is whether or not the generally-visible flag is set."
308 (slot-ref gameobj 'generally-visible))
310 (define* (gameobj-visible-name actor message #:key whos-looking)
312 (define we-are-visible
313 ((slot-ref actor 'visible-to-player?) actor whos-looking))
315 (define name-to-return
318 (match (slot-ref actor 'name)
319 ((? procedure? name-proc)
320 (name-proc actor whos-looking))
325 (<-reply message #:text name-to-return))
327 (define (gameobj-self-destruct gameobj)
328 "General gameobj self destruction routine"
329 ;; Unregister from being in any particular room
330 (gameobj-set-loc! gameobj #f)
331 (slot-set! gameobj 'destructed #t)
333 (self-destruct gameobj))
335 (define* (gameobj-act-self-destruct gameobj message #:key why)
336 "Action routine for self destruction"
337 (gameobj-self-destruct gameobj))
339 ;; Unless an actor has a tell message, we just ignore it
340 (define gameobj-tell-no-op
343 (define (gameobj-replace-data-occupants actor)
344 "The general purpose list of replacement data"
345 (list #:occupants (hash-map->list (lambda (occupant _) occupant)
346 (slot-ref actor 'occupants))))
348 (define (gameobj-replace-data* actor)
349 ;; For now, just call gameobj-replace-data-occupants.
350 ;; But there may be more in the future!
351 (gameobj-replace-data-occupants actor))
353 ;; So sad that objects must assist in their replacement ;_;
354 ;; But that's life in a live hacked game!
355 (define (gameobj-act-assist-replace actor message)
356 "Vanilla method for assisting in self-replacement for live hacking"
357 (apply <-reply message
358 (gameobj-replace-data* actor)))
361 ;;; Utilities every gameobj has
362 ;;; ---------------------------
364 (define (dyn-ref gameobj special-symbol)
365 "Dynamically look up a special object from the gm"
366 (match special-symbol
367 ;; if it's a symbol, look it up dynamically
369 (mbody-val (<-wait (slot-ref gameobj 'gm) 'lookup-special
370 #:symbol special-symbol)))
371 ;; if it's false, return nothing
373 ;; otherwise it's probably an address, return it as-is
381 (define* (cmd-take gameobj message #:key direct-obj)
382 (define player (message-from message))
384 (mbody-val (<-wait player 'get-name)))
386 (mbody-val (<-wait player 'get-loc)))
387 (define our-name (slot-ref gameobj 'name))
388 (define self-should-take
389 (slot-ref-maybe-runcheck gameobj 'takeable player))
390 ;; @@: Is there any reason to allow the room to object in the way
391 ;; that there is for dropping? It doesn't seem like it.
392 ;; TODO: Allow gameobj to customize
394 ;; Set the location to whoever's picking us up
396 (gameobj-set-loc! gameobj player)
398 #:text (format #f "You pick up ~a.\n"
400 (<- player-loc 'tell-room
401 #:text (format #f "~a picks up ~a.\n"
406 #:text (format #f "It doesn't seem like you can take ~a.\n"
409 (define* (cmd-drop gameobj message #:key direct-obj)
410 (define player (message-from message))
412 (mbody-val (<-wait player 'get-name)))
414 (mbody-val (<-wait player 'get-loc)))
415 (define our-name (slot-ref gameobj 'name))
417 (slot-ref-maybe-runcheck gameobj 'dropable player))
418 (define (room-objection-to-drop)
419 (mbody-receive (drop-ok? #:key why-not) ; does the room object to dropping?
420 (<-wait player-loc 'ok-to-drop-here? player (actor-id gameobj))
422 ;; Either give the specified reason, or give a boilerplate one
424 `("You'd love to drop " ,our-name
425 " but for some reason it doesn't seem like you can"
426 " do that here.")))))
430 #:text `("It doesn't seem like you can drop " ,our-name
431 " here, because you don't seem to be anywhere?!?")))
432 ;; TODO: Let ourselves supply a reason why not.
435 #:text (format #f "It doesn't seem like you can drop ~a.\n"
437 ((room-objection-to-drop)
439 #:text room-objection-to-drop))
441 (gameobj-set-loc! gameobj player-loc)
442 ;; TODO: Allow more flavortext here.
444 #:text (format #f "You drop ~a.\n"
446 (<- player-loc 'tell-room
447 #:text (format #f "~a drops ~a.\n"