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 systems actors)
25 #:use-module (8sync agenda)
26 #:use-module (srfi srfi-1)
27 #:use-module (ice-9 match)
28 #:use-module (oop goops)
36 gameobj-self-destruct))
42 ;;; Actions supported by all gameobj
43 (define gameobj-actions
45 (init (wrap-apply gameobj-init))
46 (get-commands (wrap-apply gameobj-get-commands))
47 (get-container-commands (wrap-apply gameobj-get-container-commands))
48 (get-occupants (wrap-apply gameobj-get-occupants))
49 (add-occupant! (wrap-apply gameobj-add-occupant!))
50 (remove-occupant! (wrap-apply gameobj-remove-occupant!))
51 (set-loc! (wrap-apply gameobj-act-set-loc!))
52 (get-name (wrap-apply gameobj-get-name))
53 (set-name! (wrap-apply gameobj-act-set-name!))
54 (get-desc (wrap-apply gameobj-get-desc))
55 (goes-by (wrap-apply gameobj-act-goes-by))
56 (visible-name (wrap-apply gameobj-visible-name))
57 (self-destruct (wrap-apply gameobj-act-self-destruct))
58 (tell (wrap-apply gameobj-tell-no-op))))
60 ;;; *all* game components that talk to players should somehow
61 ;;; derive from this class.
62 ;;; And all of them need a GM!
64 (define-class <gameobj> (<actor>)
69 ;; Uses a hash table like a set (values ignored)
70 (occupants #:init-thunk make-hash-table)
73 (gm #:init-keyword #:gm
75 ;; a name to be known by
76 (name #:init-keyword #:name
78 (goes-by #:init-keyword #:goes-by
82 #:init-keyword #:desc)
84 ;; Commands we can handle
85 (commands #:init-value '())
87 ;; Commands we can handle by being something's container
88 (container-commands #:init-value '())
91 (simple-dispatcher gameobj-actions))
93 ;; Most objects are generally visible by default
94 (generally-visible #:init-value #t
95 #:init-keyword #:generally-visible)
96 ;; @@: Would be preferable to be using generic methods for this...
97 ;; Hopefully we can port this to Guile 2.2 soon...
99 #:init-value (wrap-apply gameobj-visible-to-player?)))
102 ;;; gameobj message handlers
103 ;;; ========================
105 ;; Kind of a useful utility, maybe?
106 (define (simple-slot-getter slot)
107 (lambda (actor message)
108 (reply-message actor message
109 #:val (slot-ref actor slot))))
112 ;; @@: This could be kind of a messy way of doing gameobj-init
113 ;; stuff. If only we had generic methods :(
114 (define-mhandler (gameobj-init actor message)
115 "Your most basic game object init procedure. Does nothing."
118 (define (gameobj-goes-by gameobj)
119 "Find the name we go by. Defaults to #:name if nothing else provided."
120 (cond ((slot-ref gameobj 'goes-by) =>
122 ((slot-ref gameobj 'name) =>
127 (define (gameobj-act-goes-by actor message)
128 "Reply to a message requesting what we go by."
129 (<-reply actor message
130 #:goes-by (gameobj-goes-by actor)))
132 (define (val-or-run val-or-proc)
133 "Evaluate if a procedure, or just return otherwise"
134 (if (procedure? val-or-proc)
138 (define (filter-commands commands verb)
141 (equal? (command-verbs cmd)
145 (define-mhandler (gameobj-get-commands actor message verb)
146 "Get commands a co-occupant of the room might execute for VERB"
147 (define filtered-commands
148 (filter-commands (val-or-run (slot-ref actor 'commands))
150 (<-reply actor message
151 #:commands filtered-commands
152 #:goes-by (gameobj-goes-by actor)))
154 (define-mhandler (gameobj-get-container-commands actor message verb)
155 "Get commands as the container / room of message's sender"
156 (define filtered-commands
157 (filter-commands (val-or-run (slot-ref actor 'container-commands))
159 (<-reply actor message #:commands filtered-commands))
161 (define-mhandler (gameobj-add-occupant! actor message who)
162 "Add an actor to our list of present occupants"
163 (hash-set! (slot-ref actor 'occupants)
166 (define-mhandler (gameobj-remove-occupant! actor message who)
167 "Remove an occupant from the room."
168 (hash-remove! (slot-ref actor 'occupants) who))
170 (define* (gameobj-occupants gameobj #:key exclude)
172 (lambda (occupant _ prev)
175 ;; Empty list and #f are non-exclusion
178 ;; A list of addresses... since our address object is (annoyingly)
179 ;; currently a simple cons cell...
180 ((exclude-1 ... exclude-rest)
181 (pk 'failboat (member occupant (pk 'exclude-lst exclude))))
182 ;; Must be an individual address!
183 (_ (equal? occupant exclude))))
186 (cons occupant prev)))
188 (slot-ref gameobj 'occupants)))
190 (define-mhandler (gameobj-get-occupants actor message)
191 "Get all present occupants of the room."
192 (define exclude (message-ref message 'exclude #f))
194 (gameobj-occupants actor #:exclude exclude))
196 (<-reply actor message
197 #:occupants occupants))
199 (define (gameobj-set-loc! gameobj loc)
200 "Set the location of this object."
201 (define old-loc (gameobj-loc gameobj))
202 (format #t "DEBUG: Location set to ~s for ~s\n"
203 loc (actor-id-actor gameobj))
205 (slot-set! gameobj 'loc loc)
206 ;; Change registation of where we currently are
208 (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))
210 (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj))))
212 ;; @@: Should it really be #:id ? Maybe #:loc-id or #:loc?
213 (define-mhandler (gameobj-act-set-loc! actor message loc)
214 "Action routine to set the location."
215 (gameobj-set-loc! actor loc))
217 (define gameobj-get-name (simple-slot-getter 'name))
219 (define-mhandler (gameobj-act-set-name! actor message val)
220 (slot-set! actor 'name val))
222 (define-mhandler (gameobj-get-desc actor message whos-looking)
224 (match (slot-ref actor 'desc)
225 ((? procedure? desc-proc)
226 (desc-proc actor whos-looking))
228 (<-reply actor message #:val desc-text))
230 (define (gameobj-visible-to-player? gameobj whos-looking)
231 "Check to see whether we're visible to the player or not.
232 By default, this is whether or not the generally-visible flag is set."
233 (slot-ref gameobj 'generally-visible))
235 (define-mhandler (gameobj-visible-name actor message whos-looking)
237 (define we-are-visible
238 ((slot-ref actor 'visible-to-player?) actor whos-looking))
240 (define name-to-return
243 (match (slot-ref actor 'name)
244 ((? procedure? name-proc)
245 (name-proc actor whos-looking))
250 (<-reply actor message #:text name-to-return))
252 (define (gameobj-self-destruct gameobj)
253 "General gameobj self destruction routine"
254 ;; Unregister from being in any particular room
255 (gameobj-set-loc! gameobj #f)
257 (self-destruct gameobj))
259 (define-mhandler (gameobj-act-self-destruct gameobj message)
260 "Action routine for self destruction"
261 (gameobj-self-destruct gameobj))
263 ;; Unless an actor has a tell message, we just ignore it
264 (define gameobj-tell-no-op