1 ;;----------------------------------------------------------------------------
2 ;; Containers - objects that contain stuff
3 ;;----------------------------------------------------------------------------
4 ;;----------------------------------------------------------------------------
6 ;;----------------------------------------------------------------------------
7 (define (mk-contents . contents)
8 (filter notnull? contents))
10 (define (roll-100 prob)
11 (>= prob (modulo (random-next) 100)))
13 (define (roll-to-add prob dice type)
15 (list (kern-dice-roll dice) type)
18 ;;----------------------------------------------------------------------------
19 ;; Corpse -- not really a container, if you search it then it sort of acts like
20 ;; opening a container
21 ;;----------------------------------------------------------------------------
22 (define (corpse-mk loot)
24 (define (corpse-loot corpse) (car corpse))
25 (define (corpse-set-loot! corpse val) (set-car! corpse val))
26 (define (corpse-loot-entry-q loot) (car loot))
27 (define (corpse-loot-entry-type loot) (eval (cadr loot)))
29 (define (corpse-search kobj)
30 (let* ((corpse (kobj-gob-data kobj))
31 (loot (corpse-loot corpse)))
32 (if (not (null? loot))
33 (let ((loc (kern-obj-get-location kobj)))
35 (kern-obj-put-at (kern-mk-obj (corpse-loot-entry-type entry)
36 (corpse-loot-entry-q entry))
39 (corpse-set-loot! corpse nil)))))
43 (method 'search corpse-search)))
45 (mk-obj-type 't_corpse "°äÂÎ" s_corpse layer-item corpse-ifc)
48 (bind (kern-mk-obj t_corpse 1)
51 ;; mk-corpse2 -- loot: a list of (quantity type) lists
52 (define (mk-corpse2 loot)
53 (bind (kern-mk-obj t_corpse 1)
56 (define (mk-corpse-with-loot)
57 (mk-corpse2 (mk-quoted-treasure-list (+ 1(modulo (random-next)
60 ;;----------------------------------------------------------------------------
61 ;; This next section is an experimental new container type. It attempts to
62 ;; bypass the kernel's built-in Container class and implement everything in the
63 ;; script as a normal kernel Object that responds to the 'open signal the same
64 ;; way a kernel Container would respond to the open command.
66 ;; This currently works. The next step is to implement the ability to add (and
67 ;; remove or disable) traps on a container. The means of doing so will be
68 ;; implemented here in the script, so the kernel won't need to know about
69 ;; trapped containers when this all works, and the kernel's Container class can
70 ;; be stripped back to a basic Inventory class.
72 ;; Define the gob structure and procedures. The contents should be a single
73 ;; quoted list, for example:
79 ;; Using the quotes is not only cleaner in the declarations, it automatically
80 ;; ensures that the contents are safe to save and reload as part of the gob
81 ;; because they are stored in the gob merely as symbols.
83 ;; Each container has a (often empty) list of traps. See traps.scm for details
84 ;; of trap implementations. When traps are attached to a container, the type of
85 ;; trap is specified, and an instance of that type is added to the list.yn
87 (define (mk-container contents sprites-tag)
97 (define (is-container? gob) (eq? (car gob) 'container))
99 (define (container-contents gob) (cadr gob))
100 (define (container-set-contents! gob val) (set-car! (cdr gob) val))
102 (define (container-traps gob) (caddr gob))
103 (define (container-set-traps! gob traps) (set-car! (cdr (cdr gob)) traps))
104 (define (container-add-trap! gob trap-type)
105 (container-set-traps! gob
106 (cons (mk-trap (eval trap-type))
107 (container-traps gob))))
109 (define (container-destroyed? gob) (cadddr gob))
110 (define (container-destroy! gob) (set-car! (cdddr gob) #t))
112 (define (container-sprites gob) (eval (list-ref gob 4)))
114 (define (container-locked? gob) (list-ref gob 5))
115 (define (container-set-locked! gob val) (set-car! (list-tail gob 5) val))
117 (define (container-magic-locked? gob) (list-ref gob 6))
118 (define (container-set-magic-locked! gob val) (set-car! (list-tail gob 6) val))
120 (define (container-key gob) (list-ref gob 7))
121 (define (container-set-key! gob ktype) (set-car! (list-tail gob 7) ktype))
122 (define (container-needs-key? gob) (not (null? (container-key gob))))
123 (define (container-key-fits? gob ktype)
124 (let ((key (safe-eval (container-key gob))))
125 (and (not (null? key))
128 ;; For now always false, since they destroy themselves on open. Might change
130 (define (container-open? gob) #f)
133 (define (content-type content) (cadr content))
134 (define (content-quantity content) (car content))
136 ;; This is the heart of the implementation. This procedure runs when the
137 ;; container object gets the 'open signal, which is sent by the kernel in
138 ;; response to the player's o)pen command followed by selection of this
139 ;; object. It expects kobj to be a kernel object which is bound to a container
140 ;; gob following the above format (the constructors further down illustrate how
141 ;; to create such an object).
143 ;; Opening the container creates objects based on the types and quantities
144 ;; listed in the container's content list and deposits these objects on the
145 ;; ground where the container is. Then it removes the container, which likely
146 ;; results in its destruction.
148 ;; Before opening this applies all the traps attached to the container. Note
149 ;; that the self-destruct trap, as currently implemented, does not work as
150 ;; expected, because it relies on the removal of the container from the map as
151 ;; a means of destroying it; and that is not sufficient here.
152 (define (kcontainer-open kobj kchar)
153 (let ((container (kobj-gob-data kobj))
154 (loc (kern-obj-get-location kobj))
158 ((container-magic-locked? container)
159 (kern-log-msg "ËâË¡¤ÇÉõ°õ¤µ¤ì¤Æ¤¤¤ë¡ª\n")
161 ((container-locked? container)
162 (kern-log-msg "»Ü¾û¤µ¤ì¤Æ¤¤¤ë¡ª\n")
166 ;; Applying traps can destroy both kobj and kchar
167 (kern-obj-inc-ref kobj)
168 (kern-obj-inc-ref kchar)
170 ;; Apply traps (see trap.scm for trap-trigger)
172 (trap-trigger trap kobj kchar))
173 (container-traps container))
175 (cond ((container-destroyed? container)
179 (map (lambda (content)
180 (let ((newobj (kern-mk-obj (eval (content-type content))
181 (content-quantity content))))
182 (kern-obj-put-at newobj loc)))
183 (container-contents container))
185 ;; Remove the container from the map
186 (kern-obj-remove kobj)
190 ;; Done with references
191 (kern-obj-dec-ref kobj)
192 (kern-obj-dec-ref kchar)
195 (define (kcontainer-add-trap kobj trap-sym)
196 (container-add-trap! (kobj-gob-data kobj)
199 (define (kcontainer-get-traps kobj)
200 (container-traps (kobj-gob-data kobj)))
202 (define (kcontainer-rm-traps kobj)
203 (container-set-traps! (kobj-gob-data kobj) nil))
205 (define (kcontainer-self-destruct kobj)
206 (let ((container (kobj-gob-data kobj)))
207 (container-set-contents! container nil)
208 (container-destroy! container)
209 (kern-obj-remove kobj)
212 (define (kcontainer-search kobj kchar)
213 ;; Searching can trigger traps, which can destroy both kobj and kchar
214 (kern-obj-inc-ref kobj)
215 (kern-obj-inc-ref kchar)
216 (kern-log-begin "ÊõÈ¢¤òÄ´¤Ù¤¿¡Ä")
217 (let ((container (gob kobj)))
218 (if (foldr (lambda (detected? trap)
219 (trap-search trap kobj kchar)
220 (if (trap-tripped? trap)
221 (container-set-traps! container
222 (filter (lambda (trap2)
223 (not (equal? trap trap2)))
224 (container-traps container))))
225 (or detected? (trap-detected? trap)))
227 (container-traps container))
228 (kern-log-end "櫤¬»Å³Ý¤±¤é¤ì¤Æ¤¤¤ë¡ª")
229 (kern-log-end "櫤Ϥʤ¤¤è¤¦¤À¡ª")
231 ;; Done with references
232 (kern-obj-dec-ref kobj)
233 (kern-obj-dec-ref kchar)
236 (define (kcontainer-describe kcontainer count)
237 (let ((container (gob kcontainer)))
238 (kern-log-continue "")
239 (if (container-magic-locked? container)
240 (kern-log-continue "ËâË¡¤ÇÉõ°õ¤µ¤ì¤¿"))
241 (if (container-locked? container)
242 (if (container-needs-key? container)
243 (kern-log-continue "»Ü¾û¤µ¤ì¤¿")
244 (kern-log-continue "Æîµþ¾û¤Î³Ý¤±¤é¤ì¤¿")))
245 (if (container-open? container)
246 (kern-log-continue "³«¤¤¤¿È¢")
247 (kern-log-continue "ÊĤ¸¤¿È¢"))
248 (kern-log-continue "(")
249 (if (foldr (lambda (described? trap)
250 (cond ((trap-detected? trap)
252 (kern-log-continue "¡¢"))
253 (kern-log-continue (trap-name trap))
254 (if (trap-tripped? trap)
255 (kern-log-continue "[²ò½üºÑ]"))
260 (container-traps container))
261 (kern-log-continue "櫤¬¤¢¤ë")
262 (kern-log-continue "櫤Ϥʤ¤¤è¤¦¤À")
264 (kern-log-continue ")")
267 (define (container-get-sprite container)
268 (list-ref (container-sprites container)
269 (let ((index (if (container-magic-locked? container)
270 (if (container-locked? container)
271 3 ;; magic locked & locked
274 (if (container-locked? container)
278 (println "sprite-index: " index)
281 (define (kcontainer-update-sprite kcontainer)
282 (kern-obj-set-sprite kcontainer (container-get-sprite (gob kcontainer)))
285 (define (kcontainer-lock kcontainer khandler)
286 (let ((container (gob kcontainer)))
287 (println "container-lock: " container)
288 (cond ((container-open? container) (kern-log-msg "ÊĤ¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
289 ((container-locked? container) (kern-log-msg "´û¤Ë»Ü¾û¤µ¤ì¤Æ¤¤¤ë¡ª\n") #f)
291 (container-set-locked! container #t)
292 (kcontainer-update-sprite kcontainer)
295 (define (kcontainer-unlock kcontainer khandler)
296 (let ((container (gob kcontainer)))
297 (cond ((container-open? container) (kern-log-msg "ÊĤ¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
298 ((not (container-locked? container)) (kern-log-msg "»Ü¾û¤µ¤ì¤Æ¤¤¤Ê¤¤¡ª\n") #f)
299 ((container-needs-key? container) (kern-log-msg "¸°¤¬É¬ÍפÀ¡ª\n") #f)
301 (container-set-locked! container #f)
302 (kcontainer-update-sprite kcontainer)
305 (define (kcontainer-magic-lock kcontainer khandler)
306 (let ((container (gob kcontainer)))
307 (cond ((container-open? container) (kern-log-msg "ÊĤ¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
308 ((container-magic-locked? container)
309 (kern-log-msg "´û¤ËËâË¡¤ÇÉõ°õ¤µ¤ì¤Æ¤¤¤ë¡ª\n") #f)
311 (container-set-magic-locked! container #t)
312 (kcontainer-update-sprite kcontainer)
315 (define (kcontainer-magic-unlock kcontainer khandler)
316 (let ((container (gob kcontainer)))
317 (println "container-magic-unlock: " container)
318 (cond ((container-open? container) (kern-log-msg "ÊĤ¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
319 ((not (container-magic-locked? container))
320 (kern-log-msg "ËâË¡¤ÇÉõ°õ¤µ¤ì¤Æ¤¤¤Ê¤¤¡ª\n") #f)
322 (container-set-magic-locked! container #f)
323 (kcontainer-update-sprite kcontainer)
326 (define (kcontainer-use-key kcontainer key-type)
327 (let ((container (gob kcontainer)))
328 (println "container-use-key: " container)
329 (cond ((container-open? container) (kern-log-msg "ÊĤ¸¤Æ¤¤¤Ê¤¤¡ª"))
330 ((not (container-key-fits? container key-type)) (kern-log-msg "¤³¤Î¸°¤Ï¹ç¤ï¤Ê¤¤¡ª"))
331 ((container-locked? container)
332 (container-set-locked! container #f)
333 (kcontainer-update-sprite kcontainer)
336 (container-set-locked! container #t)
337 (kcontainer-update-sprite kcontainer)
340 (define (kcontainer-lock-with-key kcontainer ktype)
341 (let ((container (gob kcontainer)))
342 (println "container-lock-with-key: " container " " ktype)
343 (cond ((container-open? container) (kern-log-msg "ÊĤ¸¤Æ¤¤¤Ê¤¤¡ª"))
344 ((container-locked? container) (kern-log-msg "´û¤Ë»Ü¾û¤µ¤ì¤Æ¤¤¤ë¡ª"))
346 (container-set-key! container ktype)
347 (container-set-locked! container #t)
348 (kcontainer-update-sprite kcontainer)
351 (define (kcontainer-get-unlock-dc kcontainer)
352 (let ((val (container-locked? (gob kcontainer))))
353 ;; make it backwards-compatible for old saved games where the value is a bool
356 (if val dc-normal 0))))
358 (define (kcontainer-get-magic-unlock-dc kcontainer)
359 (let ((val (container-magic-locked? (gob kcontainer))))
360 ;; make it backwards-compatible for old saved games where the value is a bool
363 (if val dc-normal 0))))
365 ;; This interface binds the 'open signal to our open procedure above.
366 (define container-ifc
368 (method 'open kcontainer-open)
369 (method 'add-trap kcontainer-add-trap)
370 (method 'get-traps kcontainer-get-traps)
371 (method 'rm-traps kcontainer-rm-traps)
372 (method 'self-destruct kcontainer-self-destruct)
373 (method 'search kcontainer-search)
374 (method 'describe kcontainer-describe)
376 (method 'lock kcontainer-lock)
377 (method 'unlock kcontainer-unlock)
378 (method 'magic-lock kcontainer-magic-lock)
379 (method 'magic-unlock kcontainer-magic-unlock)
380 (method 'use-key kcontainer-use-key)
381 (method 'get-unlock-dc kcontainer-get-unlock-dc)
382 (method 'get-magic-unlock-dc kcontainer-get-magic-unlock-dc)
386 ;; This constructor makes new types of objects that conform to the container
387 ;; interface above. An example of usage is below, where I make a new chest
389 (define (mk-container-type tag name sprite)
390 (mk-obj-type tag name sprite layer-mechanism container-ifc))
392 ;; Test it out. First, make a new chest type.
393 (mk-container-type 't_chest "ÊõÈ¢" s_chest)
395 ;; Define a constructor for an object of the new chest type. Example usage:
397 ;; (put (mk-chest2 '((1 t_sword)
402 ;; * Note the use of a quoted list.
404 (define chest-sprites (list s_chest
407 s_magic_locked_chest)
410 (define (mk-chest trap contents)
411 (let ((kchest (bind (kern-mk-obj t_chest 1)
412 (mk-container contents 'chest-sprites))))
413 (if (not (null? trap))
414 (container-add-trap! (kobj-gob-data kchest) trap))
417 (define (chest-add-trap kobj trap)
418 (container-add-trap! (kobj-gob-data kobj) trap))
420 ;; mk-treasure-chest -- returns a chest with 1-10 random object types
421 (define (mk-treasure-chest)
423 (mk-quoted-treasure-list (+ 1
424 (modulo (random-next)
427 ;;----------------------------------------------------------------------------
430 ;; This does not really belong here, since it is not a container, but rather an
431 ;; object that implements the 'butcher interface.
433 ;; This procedure must take two args and return a boolean in order to fit into
434 ;; the skills yusage framework.
435 (define (animal-corpse-butcher kobj kactor)
436 (kern-obj-put-at (kern-mk-obj t_food 1) (kern-obj-get-location kobj))
437 (kern-obj-remove kobj)
441 (define animal-corpse-ifc
443 (method 'butcher animal-corpse-butcher)
446 (mk-obj-type 't_animal_corpse "ưʪ¤Î»àÂÎ" s_corpse layer-item animal-corpse-ifc)