worlds/haxima-1.002/door.scm

   1 ;;----------------------------------------------------------------------------
   2 ;; Doors
   3 (define door-state-closed       0)
   4 (define door-state-open         1)
   5 (define door-state-locked       2)
   6 (define door-state-magic-locked 3)
   7
   8 (define (mk-door-state sprite opacity pclass)
   9   (list sprite opacity pclass))
  10 (define (door-state-sprite ds) (car ds))
  11 (define (door-state-opacity ds) (cadr ds))
  12 (define (door-state-pclass ds) (caddr ds))
  13
  14 (define (mk-door-states closed open locked magic-locked)
  15   (list closed open locked magic-locked))
  16
  17 ;; Define the door gob structure and procedures.
  18 (define (door-mk open? timeout port active? locked? magic-locked? type)
  19   (list open? timeout port active? locked? magic-locked? type nil nil))
  20 (define (door-open? door) (car (gob-data door)))
  21 (define (door-timeout door) (cadr (gob-data door)))
  22 (define (door-port door) (list-ref (gob-data door) 2))
  23 (define (door-active? door) (list-ref (gob-data door) 3))
  24 (define (door-locked? door) (list-ref (gob-data door) 4))
  25 (define (door-magic-locked? door) (list-ref (gob-data door) 5))
  26 (define (door-states door) (eval (list-ref (gob-data door) 6)))
  27 (define (door-traps door) (list-ref (gob-data door) 7))
  28 (define (door-trapped? door) (not (null? (door-traps door))))
  29 (define (door-key door) (list-ref (gob-data door) 8))
  30 (define (door-needs-key? door) (not (null? (door-key door))))
  31 (define (door-key-fits? door ktype)
  32   (let ((key (safe-eval (door-key door))))
  33     (and (not (null? key))
  34          (eqv? key ktype))))
  35
  36 (define (door-set-open door val) (set-car! (gob-data door) val))
  37 (define (door-set-timeout! door time) (set-car! (cdr (gob-data door)) time))
  38 (define (door-set-port! door port) (set-car! (cddr (gob-data door)) port))
  39 (define (door-set-active! door val) (set-car! (cdddr (gob-data door)) val))
  40 (define (door-set-locked! door val) (set-car! (cddddr (gob-data door)) val))
  41 (define (door-set-magic-locked! door val)
  42   (list-set-ref! (gob-data door) 5 val))
  43 (define (door-set-traps! door val) (list-set-ref! (gob-data door) 7 val))
  44 (define (door-add-trap! door trap-type)
  45   (door-set-traps! door (cons (mk-trap (eval trap-type))
  46                               (door-traps door))))
  47 (define (door-set-key! door key-type-tag)
  48   (list-set-ref! (gob-data door) 8 key-type-tag))
  49
  50 (define (door-send-signal kdoor sig)
  51   (let ((door (kobj-gob kdoor)))
  52     (if (not (door-active? door))
  53         (begin
  54           (let ((port (door-port door)))
  55             (door-set-active! door #t)
  56             (if (not (null? port))
  57                 (begin
  58                   ((kobj-ifc (eval port)) sig (eval port) kdoor)))
  59             (door-set-active! door #f))))))
  60
  61 (define (door-update-kstate kdoor)
  62   (define (update state-no)
  63     (let ((state (list-ref (door-states (kobj-gob kdoor)) state-no)))
  64       (kern-obj-set-sprite kdoor (door-state-sprite state))
  65       (kern-obj-set-opacity kdoor (door-state-opacity state))
  66       (kern-obj-set-pclass kdoor (door-state-pclass state))))
  67   (let ((door (kobj-gob kdoor)))
  68     (cond ((door-magic-locked? door) (update door-state-magic-locked))
  69           ((door-locked? door)       (update door-state-locked))
  70           ((door-open? door)         (update door-state-open))
  71           (else                      (update door-state-closed))))
  72   (kern-map-set-dirty)
  73   kdoor)
  74
  75 (define (door-trip-traps kdoor kchar)
  76   (let ((door (kobj-gob kdoor))
  77         )
  78     (kern-obj-inc-ref kdoor)
  79     (kern-obj-inc-ref kchar)
  80     (map (lambda (trap)
  81            (trap-trigger trap kdoor kchar))
  82          (door-traps door))
  83     (door-set-traps! door nil)
  84     (kern-obj-dec-ref kdoor)
  85     (kern-obj-dec-ref kchar)))
  86
  87 (define (door-open kdoor khandler)
  88   (let ((door (kobj-gob kdoor)))
  89     (cond
  90      ((door-magic-locked? door)
  91       (kern-log-msg "ËâË¡¤ÇÉõ°õ¤µ¤ì¤Æ¤¤¤ë¡ª\n")
  92       #f)
  93      ((door-locked? door)
  94       (kern-log-msg "»Ü¾û¤µ¤ì¤Æ¤¤¤ë¡ª\n")
  95       #f)
  96      ((door-trapped? door)
  97       (door-trip-traps kdoor khandler)
  98       (door-open kdoor khandler)
  99       )
 100       (else
 101        (door-set-open door #t)
 102        (door-set-timeout! door 10)
 103        (door-update-kstate kdoor)
 104        (door-send-signal kdoor 'open)
 105        #t))))
 106
 107 (define (door-close kdoor khandler)
 108   ;;(display "door-close")(newline)
 109   (if (not (occupied? (kern-obj-get-location kdoor)))
 110       (let ((door (kobj-gob kdoor)))
 111         (door-set-open door #f)
 112         (door-set-timeout! door 0)
 113         (door-update-kstate kdoor)
 114         (door-send-signal kdoor 'close)
 115         #t)))
 116
 117 (define (door-lock kdoor khandler)
 118   (let ((door (kobj-gob kdoor)))
 119     ;;(display "door-lock:")(display door)(newline)
 120     (cond ((door-open? door) (kern-log-msg "ÊÄ¤¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
 121           ((door-locked? door) (kern-log-msg "´û¤Ë»Ü¾û¤µ¤ì¤Æ¤¤¤ë¡ª\n") #f)
 122           (else
 123            (door-set-locked! door #t)
 124            (door-update-kstate kdoor)
 125            #t))))
 126
 127 (define (door-unlock kdoor khandler)
 128   (let ((door (kobj-gob kdoor)))
 129     ;;(display "door-unlock:")(display door)(newline)
 130     (cond ((door-open? door) (kern-log-msg "ÊÄ¤¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
 131           ((not (door-locked? door)) (kern-log-msg "»Ü¾û¤µ¤ì¤Æ¤¤¤Ê¤¤¡ª\n") #f)
 132           ((door-needs-key? door) (kern-log-msg "¸°¤¬É¬Í×¤À¡ª\n") #f)
 133           (else
 134            (door-set-locked! door #f)
 135            (door-update-kstate kdoor)
 136            #t))))
 137
 138 (define (door-magic-lock kdoor khandler)
 139   (let ((door (kobj-gob kdoor)))
 140     ;;(display "door-magic-lock:")(display door)(newline)
 141     (cond ((door-open? door) (kern-log-msg "ÊÄ¤¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
 142           ((door-magic-locked? door)
 143            (kern-log-msg "´û¤ËËâË¡¤ÇÉõ°õ¤µ¤ì¤Æ¤¤¤ë¡ª\n") #f)
 144           (else
 145            (door-set-magic-locked! door #t)
 146            (door-update-kstate kdoor)
 147            #t))))
 148
 149 (define (door-magic-unlock kdoor khandler)
 150   (let ((door (kobj-gob kdoor)))
 151     ;;(display "door-magic-unlock:")(display door)(newline)
 152     (cond ((door-open? door) (kern-log-msg "ÊÄ¤¸¤Æ¤¤¤Ê¤¤¡ª\n") #f)
 153           ((not (door-magic-locked? door))
 154            (kern-log-msg "ËâË¡¤ÇÉõ°õ¤µ¤ì¤Æ¤¤¤Ê¤¤¡ª\n") #f)
 155           (else
 156            (door-set-magic-locked! door #f)
 157            (door-update-kstate kdoor)
 158            #t))))
 159
 160 (define (door-handle kdoor khandler)
 161   (let ((door (kobj-gob kdoor)))
 162     (if (door-open? door)
 163         (door-close kdoor khandler)
 164         (door-open kdoor khandler))))
 165
 166 (define (door-exec kdoor)
 167   (let ((door (kobj-gob kdoor)))
 168     (if (door-open? door)
 169         (let ((timeout (door-timeout door)))
 170           (cond ((> timeout 1) (door-set-timeout! door (- timeout 1)))
 171                 ((= timeout 1) (door-close kdoor '())))))))
 172
 173
 174 (define (door-connect kobj kto-tag)
 175   (let ((door (kobj-gob kobj)))
 176     (door-set-port! door kto-tag)))
 177
 178 (define (door-add-trap kdoor trap-sym)
 179   (let ((door (kobj-gob kdoor)))
 180     (door-add-trap! door trap-sym)))
 181
 182 (define (door-get-traps kdoor)
 183   (door-traps (kobj-gob kdoor)))
 184
 185 (define (door-rm-traps kdoor)
 186   (let ((door (kobj-gob kdoor)))
 187     (door-set-traps! door nil)))
 188
 189 (define (door-use-key kdoor key-type)
 190   (let ((door (kobj-gob kdoor)))
 191     (cond ((door-open? door) (kern-log-msg "ÊÄ¤¸¤Æ¤¤¤Ê¤¤¡ª"))
 192           ((not (door-key-fits? door key-type)) (kern-log-msg "¸°¤¬¹ç¤ï¤Ê¤¤¡ª"))
 193           ((door-locked? door)
 194            (door-set-locked! door #f)
 195            (door-update-kstate kdoor))
 196           (else
 197            (door-set-locked! door #t)
 198            (door-update-kstate kdoor)))))
 199
 200 (define (door-search kdoor kchar)
 201   (kern-log-begin "Èâ¤òÄ´¤Ù¤¿¡Ä")
 202   (let ((door (kobj-gob kdoor)))
 203     (if (foldr (lambda (detected? trap)
 204                  (trap-search trap kdoor kchar)
 205                  (if (trap-tripped? trap)
 206                      (door-set-traps! door
 207                                       (filter (lambda (trap2)
 208                                                 (not (equal? trap trap2)))
 209                                               (door-traps door))))
 210                  (or detected? (trap-detected? trap)))
 211                #f
 212                (door-traps door))
 213         (kern-log-end "æ«¤¬»Å³Ý¤±¤é¤ì¤Æ¤¤¤ë¡ª")
 214         (kern-log-end "æ«¤Ï¤Ê¤¤¤è¤¦¤À¡ª")
 215         )))
 216
 217 (define (door-describe kdoor count)
 218   (let ((door (kobj-gob kdoor)))
 219     (kern-log-continue "")
 220     (if (door-magic-locked? door)
 221         (kern-log-continue "ËâË¡¤ÇÉõ°õ¤µ¤ì¤¿"))
 222     (if (door-locked? door)
 223         (if (door-needs-key? door)
 224             (kern-log-continue "»Ü¾û¤µ¤ì¤¿")
 225             (kern-log-continue "Æîµþ¾û¤Î³Ý¤±¤é¤ì¤¿")))
 226     (if (door-open? door)
 227         (kern-log-continue "³«¤¤¤¿Èâ")
 228         (kern-log-continue "ÊÄ¤¸¤¿Èâ"))
 229     (kern-log-continue "(")
 230     (if (foldr (lambda (described? trap)
 231                  (cond ((trap-detected? trap)
 232                         (if described?
 233                             (kern-log-continue "¡¢"))
 234                         (kern-log-continue (trap-name trap))
 235                         (if (trap-tripped? trap)
 236                             (kern-log-continue "[²ò½üºÑ]"))
 237                         #t)
 238                        (else described?)))
 239                #f
 240                (door-traps door))
 241         (kern-log-continue "¤Îæ«¤¬»Å³Ý¤±¤é¤ì¤Æ¤¤¤ë")
 242         (kern-log-continue "æ«¤Ï¤Ê¤¤¤è¤¦¤À")
 243         )
 244     (kern-log-continue ")")
 245     ))
 246
 247 (define (door-get-unlock-dc kdoor)
 248   (let ((val (door-locked? (kobj-gob kdoor))))
 249     ;; make it backwards-compatible for old saved games where the value is a bool
 250     (if (number? val)
 251         val
 252         (if val dc-normal 0))))
 253
 254 (define (door-get-magic-unlock-dc kdoor)
 255   (let ((val (door-magic-locked? (kobj-gob kdoor))))
 256     ;; make it backwards-compatible for old saved games where the value is a bool
 257     (if (number? val)
 258         val
 259         (if val dc-normal 0))))
 260
 261 (define door-ifc
 262   (ifc '()
 263        (method 'exec door-exec)
 264        (method 'handle door-handle)
 265        (method 'open door-open)
 266        (method 'close door-close)
 267        (method 'init door-update-kstate)
 268        (method 'connect door-connect)
 269        (method 'lock door-lock)
 270        (method 'unlock door-unlock)
 271        (method 'magic-lock door-magic-lock)
 272        (method 'magic-unlock door-magic-unlock)
 273        (method 'add-trap door-add-trap)
 274        (method 'get-traps door-get-traps)
 275        (method 'rm-traps door-rm-traps)
 276        (method 'use-key door-use-key)
 277        (method 'search door-search)
 278        (method 'describe door-describe)
 279        (method 'get-unlock-dc door-get-unlock-dc)
 280        (method 'get-magic-unlock-dc door-get-magic-unlock-dc)
 281        ))
 282
 283 ;; Create the kernel "door" type
 284 (mk-obj-type 't_door "Èâ" s_stone_arch layer-mechanism
 285              door-ifc)
 286
 287 (define (door-state-factory
 288                                 arch-sprite door-sprite magic-sprite
 289                                 open-opacity closed-opacity
 290                                 open-pclass closed-pclass)
 291         (mk-door-states
 292                 (mk-door-state (mk-composite-sprite (list arch-sprite door-sprite))
 293                                         closed-opacity closed-pclass)
 294                 (mk-door-state arch-sprite      open-opacity open-pclass)
 295                 (mk-door-state (mk-composite-sprite (list arch-sprite door-sprite s_door_lock))
 296                                         closed-opacity closed-pclass)
 297                 (mk-door-state (mk-composite-sprite (list arch-sprite door-sprite s_door_magiclock))
 298                                         closed-opacity closed-pclass)
 299         ))
 300
 301 ;; Types for common door types
 302 (define solid-wood-door-in-stone
 303         (door-state-factory
 304                         s_stone_arch s_door_wood s_door_magiclock
 305                         #f #t
 306                         pclass-none pclass-wall))
 307
 308 (define windowed-wood-door-in-stone
 309         (door-state-factory
 310                         s_stone_arch s_door_windowed s_door_magiclock
 311                         #f #f
 312                         pclass-none pclass-window))
 313
 314 (define solid-wood-door-in-rock
 315         (door-state-factory
 316                         s_rock_arch s_door_wood s_door_magiclock
 317                         #f #t
 318                         pclass-none pclass-wall))
 319
 320 (define windowed-wood-door-in-rock
 321         (door-state-factory
 322                         s_rock_arch s_door_windowed s_door_magiclock
 323                         #f #f
 324                         pclass-none pclass-window))
 325
 326 ;;----------------------------------------------------------------------------
 327 ;; mk-door -- make and initialize a door object
 328 ;;
 329 ;; Used by the startup scripts when creating new doors.
 330 ;;
 331 ;;          type: one of the door state sets listed above
 332 ;;        locked: true iff door starts out locked
 333 ;;  magic-locked: true iff door starts out magically locked
 334 ;;  connected-to: nil, or the tag of an object the door forwards signals to
 335 ;;----------------------------------------------------------------------------
 336 (define (mk-door-full type locked? magic-locked? connected-to)
 337   (bind (kern-mk-obj t_door 1)
 338         (door-mk #f 0 connected-to #f locked? magic-locked? type)))
 339
 340 ;; Backward-compatible curried constructors
 341 (define (mk-door) (mk-door-full 'solid-wood-door-in-stone #f #f nil))
 342 (define (mk-door-in-rock) (mk-door-full 'solid-wood-door-in-rock #f #f nil))
 343 (define (mk-locked-door) (mk-door-full 'solid-wood-door-in-stone #t #f nil))
 344 (define (mk-locked-door-in-rock) (mk-door-full 'solid-wood-door-in-rock #t #f nil))
 345 (define (mk-connected-door tag) (mk-door-full 'solid-wood-door-in-stone #f #f tag))
 346 (define (mk-windowed-door) (mk-door-full 'windowed-wood-door-in-stone #f #f nil))
 347 (define (mk-windowed-door-in-rock) (mk-door-full 'windowed-wood-door-in-rock #f #f nil))
 348 (define (mk-magic-locked-door) (mk-door-full 'solid-wood-door-in-stone #f #t nil))
 349 (define (mk-locked-windowed-door)
 350   (mk-door-full 'windowed-wood-door-in-stone #t #f nil))
 351 (define (mk-locked-windowed-door-in-rock)
 352   (mk-door-full 'windowed-wood-door-in-rock #t #f nil))
 353
 354 (define (lock-door-with-key kdoor key-type-tag)
 355   (lock-door kdoor nil)
 356   (door-set-key! (kobj-gob kdoor) key-type-tag)
 357   )
 358
 359
 360 ;; Add a trap to a door
 361 (define (trap-door kdoor trap-tag)
 362   (ifccall kdoor 'add-trap trap-tag)
 363   kdoor
 364   )
 365
 366 (mk-obj-type 't_archway_rock "ÙÊÏ©" s_rock_arch layer-mechanism
 367              nil)
 368
 369 (mk-obj-type 't_archway_stone "ÙÊÏ©" s_stone_arch layer-mechanism
 370              nil)
 371
 372 (define (mk-archway-rock) (kern-mk-obj t_archway_rock 1))
 373
 374 (define (mk-archway-stone) (kern-mk-obj t_archway_rock 1))
 375
 376