worlds/haxima-1.002/containers.scm

   1 ;;----------------------------------------------------------------------------
   2 ;; Containers - objects that contain stuff
   3 ;;----------------------------------------------------------------------------
   4 ;;----------------------------------------------------------------------------
   5 ;; Local Procedures
   6 ;;----------------------------------------------------------------------------
   7 (define (mk-contents . contents)
   8   (filter notnull? contents))
   9
  10 (define (roll-100 prob)
  11   (>= prob (modulo (random-next) 100)))
  12
  13 (define (roll-to-add prob dice type)
  14   (if (roll-100 prob)
  15       (list (kern-dice-roll dice) type)
  16       nil))
  17
  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)
  23   (list 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)))
  28
  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)))
  34           (map (lambda (entry)
  35                  (kern-obj-put-at (kern-mk-obj (corpse-loot-entry-type entry)
  36                                                (corpse-loot-entry-q entry))
  37                                   loc))
  38                loot)
  39           (corpse-set-loot! corpse nil)))))
  40
  41 (define corpse-ifc
  42   (ifc nil
  43        (method 'search corpse-search)))
  44
  45 (mk-obj-type 't_corpse "corpse" s_corpse layer-item corpse-ifc)
  46
  47 (define (mk-corpse)
  48   (bind (kern-mk-obj t_corpse 1)
  49         (corpse-mk nil)))
  50
  51 ;; mk-corpse2 -- loot: a list of (quantity type) lists
  52 (define (mk-corpse2 loot)
  53   (bind (kern-mk-obj t_corpse 1)
  54         (corpse-mk loot)))
  55
  56 (define (mk-corpse-with-loot)
  57   (mk-corpse2 (mk-quoted-treasure-list (+ 1(modulo (random-next)
  58                                                    3)))))
  59
  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.
  65 ;;
  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.
  71
  72 ;; Define the gob structure and procedures. The contents should be a single
  73 ;; quoted list, for example:
  74 ;;
  75 ;;   '((t_sword 1)
  76 ;;     (t_arrow 5)
  77 ;;     (t_torch 2)))
  78 ;;
  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.
  82 ;;
  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
  86 ;;
  87 (define (mk-container contents sprites-tag)
  88   (list 'container
  89         contents
  90         nil ;; traps
  91         #f  ;; destroyed?
  92         sprites-tag
  93         #f  ;; locked?
  94         #f  ;; magic-locked?
  95         nil ;; key-tag
  96         ))
  97 (define (is-container? gob) (eq? (car gob) 'container))
  98
  99 (define (container-contents gob) (cadr gob))
 100 (define (container-set-contents! gob val) (set-car! (cdr gob) val))
 101
 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))))
 108
 109 (define (container-destroyed? gob) (cadddr gob))
 110 (define (container-destroy! gob) (set-car! (cdddr gob) #t))
 111
 112 (define (container-sprites gob) (eval (list-ref gob 4)))
 113
 114 (define (container-locked? gob) (list-ref gob 5))
 115 (define (container-set-locked! gob val) (set-car! (list-tail gob 5) val))
 116
 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))
 119
 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))
 126          (eqv? key ktype))))
 127
 128 ;; For now always false, since they destroy themselves on open. Might change
 129 ;; some day...
 130 (define (container-open? gob) #f)
 131
 132
 133 (define (content-type content) (cadr content))
 134 (define (content-quantity content) (car content))
 135
 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).
 142 ;;
 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.
 147 ;;
 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))
 155         )
 156
 157     (cond
 158      ((container-magic-locked? container)
 159       (kern-log-msg "Magically locked!\n")
 160       #f)
 161      ((container-locked? container)
 162       (kern-log-msg "Locked!\n")
 163       #f)
 164      (else
 165
 166       ;; Applying traps can destroy both kobj and kchar
 167       (kern-obj-inc-ref kobj)
 168       (kern-obj-inc-ref kchar)
 169
 170       ;; Apply traps (see trap.scm for trap-trigger)
 171       (map (lambda (trap)
 172              (trap-trigger trap kobj kchar))
 173            (container-traps container))
 174
 175       (cond ((container-destroyed? container)
 176              nil)
 177             (else
 178              ;; Spill contents
 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))
 184
 185              ;; Remove the container from the map
 186              (kern-obj-remove kobj)
 187              ))
 188
 189
 190       ;; Done with references
 191       (kern-obj-dec-ref kobj)
 192       (kern-obj-dec-ref kchar)
 193       ))))
 194
 195 (define (kcontainer-add-trap kobj trap-sym)
 196   (container-add-trap! (kobj-gob-data kobj)
 197                        trap-sym))
 198
 199 (define (kcontainer-get-traps kobj)
 200   (container-traps (kobj-gob-data kobj)))
 201
 202 (define (kcontainer-rm-traps kobj)
 203   (container-set-traps! (kobj-gob-data kobj) nil))
 204
 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)
 210     ))
 211
 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 "Searching chest...")
 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)))
 226                #f
 227                (container-traps container))
 228         (kern-log-end "Trap detected!")
 229         (kern-log-end "No traps detected!")
 230         ))
 231   ;; Done with references
 232   (kern-obj-dec-ref kobj)
 233   (kern-obj-dec-ref kchar)
 234   )
 235
 236 (define (kcontainer-describe kcontainer count)
 237   (let ((container (gob kcontainer)))
 238     (kern-log-continue "a ")
 239     (if (container-magic-locked? container)
 240         (kern-log-continue "magically locked, "))
 241     (if (container-locked? container)
 242         (if (container-needs-key? container)
 243             (kern-log-continue "locked (with a key), ")
 244             (kern-log-continue "padlocked, ")))
 245     (if (container-open? container)
 246         (kern-log-continue "open container ")
 247         (kern-log-continue "closed container "))
 248     (kern-log-continue "(")
 249     (if (foldr (lambda (described? trap)
 250                  (cond ((trap-detected? trap)
 251                         (if described?
 252                             (kern-log-continue ", "))
 253                         (kern-log-continue (trap-name trap))
 254                         (if (trap-tripped? trap)
 255                             (kern-log-continue "[disarmed]"))
 256                         #t)
 257                        (else
 258                         described?)))
 259                #f
 260                (container-traps container))
 261         (kern-log-continue " trap(s) detected")
 262         (kern-log-continue "no traps detected")
 263         )
 264     (kern-log-continue ")")
 265     ))
 266
 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
 272                                  2 ;; magic locked
 273                                  )
 274                              (if (container-locked? container)
 275                                  1 ;; locked
 276                                  0 ;; normal
 277                                  ))))
 278               (println "sprite-index: " index)
 279               index)))
 280
 281 (define (kcontainer-update-sprite kcontainer)
 282   (kern-obj-set-sprite kcontainer (container-get-sprite (gob kcontainer)))
 283   )
 284
 285 (define (kcontainer-lock kcontainer khandler)
 286   (let ((container (gob kcontainer)))
 287     (println "container-lock: " container)
 288     (cond ((container-open? container) (kern-log-msg "Not closed!\n") #f)
 289           ((container-locked? container) (kern-log-msg "Already locked!\n") #f)
 290           (else
 291            (container-set-locked! container #t)
 292            (kcontainer-update-sprite kcontainer)
 293            #t))))
 294
 295 (define (kcontainer-unlock kcontainer khandler)
 296   (let ((container (gob kcontainer)))
 297     (cond ((container-open? container) (kern-log-msg "Not closed!\n") #f)
 298           ((not (container-locked? container)) (kern-log-msg "Not locked!\n") #f)
 299           ((container-needs-key? container) (kern-log-msg "Needs the key!\n") #f)
 300           (else
 301            (container-set-locked! container #f)
 302            (kcontainer-update-sprite kcontainer)
 303            #t))))
 304
 305 (define (kcontainer-magic-lock kcontainer khandler)
 306   (let ((container (gob kcontainer)))
 307     (cond ((container-open? container) (kern-log-msg "Not closed!\n") #f)
 308           ((container-magic-locked? container)
 309            (kern-log-msg "Already magically locked!\n") #f)
 310           (else
 311            (container-set-magic-locked! container #t)
 312            (kcontainer-update-sprite kcontainer)
 313            #t))))
 314
 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 "Not closed!\n") #f)
 319           ((not (container-magic-locked? container))
 320            (kern-log-msg "Not magically locked!\n") #f)
 321           (else
 322            (container-set-magic-locked! container #f)
 323            (kcontainer-update-sprite kcontainer)
 324            #t))))
 325
 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 "Not closed!"))
 330           ((not (container-key-fits? container key-type)) (kern-log-msg "Key won't fit!"))
 331           ((container-locked? container)
 332            (container-set-locked! container #f)
 333            (kcontainer-update-sprite kcontainer)
 334            )
 335           (else
 336            (container-set-locked! container #t)
 337            (kcontainer-update-sprite kcontainer)
 338            ))))
 339
 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 "Not closed!"))
 344           ((container-locked? container) (kern-log-msg "Already locked!"))
 345           (else
 346            (container-set-key! container ktype)
 347            (container-set-locked! container #t)
 348            (kcontainer-update-sprite kcontainer)
 349            ))))
 350
 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
 354     (if (number? val)
 355         val
 356         (if val dc-normal 0))))
 357
 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
 361     (if (number? val)
 362         val
 363         (if val dc-normal 0))))
 364
 365 ;; This interface binds the 'open signal to our open procedure above.
 366 (define container-ifc
 367   (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)
 375
 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)
 383
 384        ))
 385
 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
 388 ;; type.
 389 (define (mk-container-type tag name sprite)
 390   (mk-obj-type tag name sprite layer-mechanism container-ifc))
 391
 392 ;; Test it out. First, make a new chest type.
 393 (mk-container-type 't_chest "chest" s_chest)
 394
 395 ;; Define a constructor for an object of the new chest type. Example usage:
 396 ;;
 397 ;; (put (mk-chest2 '((1 t_sword)
 398 ;;                   (5 t_arrow)
 399 ;;                   (2 t_torch)))
 400 ;;      5 8)
 401 ;;
 402 ;; * Note the use of a quoted list.
 403 ;;
 404 (define chest-sprites (list s_chest
 405                             s_locked_chest
 406                             s_magic_chest
 407                             s_magic_locked_chest)
 408   )
 409
 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))
 415     kchest))
 416
 417 (define (chest-add-trap kobj trap)
 418   (container-add-trap! (kobj-gob-data kobj) trap))
 419
 420 ;; mk-treasure-chest -- returns a chest with 1-10 random object types
 421 (define (mk-treasure-chest)
 422   (mk-chest nil
 423             (mk-quoted-treasure-list (+ 1
 424                                         (modulo (random-next)
 425                                                 9)))))
 426
 427 ;;----------------------------------------------------------------------------
 428 ;; Animal corpse
 429 ;;
 430 ;; This does not really belong here, since it is not a container, but rather an
 431 ;; object that implements the 'butcher interface.
 432
 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)
 438   #t
 439   )
 440
 441 (define animal-corpse-ifc
 442   (ifc nil
 443        (method 'butcher animal-corpse-butcher)
 444        ))
 445
 446 (mk-obj-type 't_animal_corpse "animal corpse" s_corpse layer-item animal-corpse-ifc)