room level messages, client disconnection
[mudsync.git] / mudsync / gameobj.scm
1 ;;; Mudsync --- Live hackable MUD
2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
3 ;;;
4 ;;; This file is part of Mudsync.
5 ;;;
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.
10 ;;;
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.
15 ;;;
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/>.
18
19 ;;; Game actor
20 ;;; ==========
21
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)
29   #:export (<gameobj>
30             gameobj-simple-name-f
31
32             gameobj-loc
33             gameobj-gm
34             gameobj-name
35
36             gameobj-occupants
37             gameobj-actions
38             gameobj-self-destruct))
39
40 ;;; Gameobj
41 ;;; =======
42
43
44 ;;; Actions supported by all gameobj
45 (define gameobj-actions
46   (build-actions
47    (init (wrap-apply gameobj-init))
48    (get-commands (wrap-apply gameobj-get-commands))
49    (get-container-commands (wrap-apply gameobj-get-container-commands))
50    (get-occupants (wrap-apply gameobj-get-occupants))
51    (add-occupant! (wrap-apply gameobj-add-occupant!))
52    (remove-occupant! (wrap-apply gameobj-remove-occupant!))
53    (set-loc! (wrap-apply gameobj-act-set-loc!))
54    (get-name (wrap-apply gameobj-get-name))
55    (get-desc (wrap-apply gameobj-get-desc))
56    (goes-by (wrap-apply gameobj-act-goes-by))
57    (visible-name (wrap-apply gameobj-visible-name))
58    (self-destruct (wrap-apply gameobj-act-self-destruct))
59    (tell (wrap-apply gameobj-tell-no-op))))
60
61 ;;; *all* game components that talk to players should somehow
62 ;;; derive from this class.
63 ;;; And all of them need a GM!
64
65 (define-class <gameobj> (<actor>)
66   ;; location id
67   (loc #:init-value #f
68        #:getter gameobj-loc)
69   
70   ;; Uses a hash table like a set (values ignored)
71   (occupants #:init-thunk make-hash-table)
72
73   ;; game master id
74   (gm #:init-keyword #:gm
75       #:getter gameobj-gm)
76   ;; a name to be known by
77   (name #:init-keyword #:name
78         #:init-value #f)
79   (goes-by #:init-keyword #:goes-by
80            #:init-value #f)
81
82   (desc #:init-value #f
83         #:init-keyword #:desc)
84
85   ;; Commands we can handle
86   (commands #:init-value '())
87
88   ;; Commands we can handle by being something's container
89   (container-commands #:init-value '())
90   (message-handler
91    #:init-value
92    (simple-dispatcher gameobj-actions))
93
94   ;; Most objects are generally visible by default
95   (generally-visible #:init-value #t
96                      #:init-keyword #:generally-visible)
97   ;; @@: Would be preferable to be using generic methods for this...
98   ;;   Hopefully we can port this to Guile 2.2 soon...
99   (visible-to-player?
100    #:init-value (wrap-apply gameobj-visible-to-player?)))
101
102
103 ;;; gameobj message handlers
104 ;;; ========================
105
106 ;; Kind of a useful utility, maybe?
107 (define (simple-slot-getter slot)
108   (lambda (actor message)
109     (reply-message actor message
110                    #:val (slot-ref actor slot))))
111
112
113 ;; @@: This could be kind of a messy way of doing gameobj-init
114 ;;   stuff.  If only we had generic methods :(
115 (define-mhandler (gameobj-init actor message)
116   "Your most basic game object init procedure.  Does nothing."
117   #f)
118
119 (define (gameobj-goes-by gameobj)
120   "Find the name we go by.  Defaults to #:name if nothing else provided."
121   (cond ((slot-ref gameobj 'goes-by) =>
122          identity)
123         ((slot-ref gameobj 'name) =>
124          (lambda (name)
125            (list name)))
126         (else '())))
127
128 (define (gameobj-act-goes-by actor message)
129   "Reply to a message requesting what we go by."
130   (<-reply actor message
131            #:goes-by (gameobj-goes-by actor)))
132
133 (define (val-or-run val-or-proc)
134   "Evaluate if a procedure, or just return otherwise"
135   (if (procedure? val-or-proc)
136       (val-or-proc)
137       val-or-proc))
138
139 (define (filter-commands commands verb)
140   (filter
141    (lambda (cmd)
142      (equal? (command-verbs cmd)
143              verb))
144    commands))
145
146 (define-mhandler (gameobj-get-commands actor message verb)
147   "Get commands a co-occupant of the room might execute for VERB"
148   (define filtered-commands
149     (filter-commands (val-or-run (slot-ref actor 'commands))
150                      verb))
151   (<-reply actor message
152            #:commands filtered-commands
153            #:goes-by (gameobj-goes-by actor)))
154
155 (define-mhandler (gameobj-get-container-commands actor message verb)
156   "Get commands as the container / room of message's sender"
157   (define filtered-commands
158     (filter-commands (val-or-run (slot-ref actor 'container-commands))
159                      verb))
160   (<-reply actor message #:commands filtered-commands))
161
162 (define-mhandler (gameobj-add-occupant! actor message who)
163   "Add an actor to our list of present occupants"
164   (hash-set! (slot-ref actor 'occupants)
165              who #t))
166
167 (define-mhandler (gameobj-remove-occupant! actor message who)
168   "Remove an occupant from the room."
169   (hash-remove! (slot-ref actor 'occupants) who))
170
171 (define* (gameobj-occupants gameobj #:key exclude)
172   (hash-fold
173    (lambda (occupant _ prev)
174      (define exclude-it?
175        (match exclude
176          ;; Empty list and #f are non-exclusion
177          (() #f)
178          (#f #f)
179          ;; A list of addresses... since our address object is (annoyingly)
180          ;; currently a simple cons cell...
181          ((exclude-1 ... exclude-rest)
182           (pk 'failboat (member occupant (pk 'exclude-lst exclude))))
183          ;; Must be an individual address!
184          (_ (equal? occupant exclude))))
185      (if exclude-it?
186          prev
187          (cons occupant prev)))
188    '()
189    (slot-ref gameobj 'occupants)))
190
191 (define-mhandler (gameobj-get-occupants actor message)
192   "Get all present occupants of the room."
193   (define exclude (message-ref message 'exclude #f))
194   (define occupants
195     (gameobj-occupants actor #:exclude exclude))
196
197   (<-reply actor message
198            #:occupants occupants))
199
200 (define (gameobj-set-loc! gameobj loc)
201   "Set the location of this object."
202   (define old-loc (gameobj-loc gameobj))
203   (format #t "DEBUG: Location set to ~s for ~s\n"
204           loc (actor-id-actor gameobj))
205
206   (slot-set! gameobj 'loc loc)
207   ;; Change registation of where we currently are
208   (if loc
209       (<-wait gameobj loc 'add-occupant! #:who (actor-id gameobj)))
210   (if old-loc
211       (<-wait gameobj old-loc 'remove-occupant! #:who (actor-id gameobj))))
212
213 ;; @@: Should it really be #:id ?  Maybe #:loc-id or #:loc?
214 (define-mhandler (gameobj-act-set-loc! actor message loc)
215   "Action routine to set the location."
216   (gameobj-set-loc! actor loc))
217
218 (define gameobj-get-name (simple-slot-getter 'name))
219
220 (define-mhandler (gameobj-get-desc actor message whos-looking)
221   (define desc-text
222     (match (slot-ref actor 'desc)
223       ((? procedure? desc-proc)
224        (desc-proc actor whos-looking))
225       (desc desc)))
226   (<-reply actor message #:val desc-text))
227
228 (define (gameobj-simple-name-f gameobj)
229   "Simplest version: return ourselves for our name."
230   (gameobj-name gameobj))
231
232 (define (gameobj-visible-to-player? gameobj whos-looking)
233   "Check to see whether we're visible to the player or not.
234 By default, this is whether or not the generally-visible flag is set."
235   (slot-ref gameobj 'generally-visible))
236
237 (define-mhandler (gameobj-visible-name actor message whos-looking)
238   ;; Are we visible?
239   (define we-are-visible
240     ((slot-ref actor 'visible-to-player?) actor whos-looking))
241
242   (define name-to-return
243     (if we-are-visible
244         ;; Return our name
245         (match (slot-ref actor 'name)
246           ((? procedure? name-proc)
247            (name-proc actor whos-looking))
248           ((? string? name)
249            name)
250           (#f #f))
251         #f))
252   (<-reply actor message #:text name-to-return))
253
254 (define (gameobj-self-destruct gameobj)
255   "General gameobj self destruction routine"
256   ;; Unregister from being in any particular room
257   (gameobj-set-loc! gameobj #f)
258   ;; Boom!
259   (self-destruct gameobj))
260
261 (define-mhandler (gameobj-act-self-destruct gameobj message)
262   "Action routine for self destruction"
263   (gameobj-self-destruct gameobj))
264
265 ;; Unless an actor has a tell message, we just ignore it
266 (define gameobj-tell-no-op
267   (const 'no-op))