1;; ---------------------------------------------------------------------------- 2;; tools.scm -- "usable" stuff that isn't a book, scroll or potion 3;; ---------------------------------------------------------------------------- 4 5;; torch -- use two in-lor spells 6(mk-usable-item 't_torch "torch" s_torch norm 7 (lambda (kobj kuser) 8 (kern-obj-add-effect kuser ef_torchlight nil) 9 result-ok)) 10 11;; picklock 12(define (picklock-proc kchar ktarg) 13 (let ((dc ((kobj-ifc ktarg) 'get-unlock-dc ktarg kchar))) 14 (if (= 0 dc) 15 ;; difficulty=0 means it is no longer locked 16 (kern-char-task-abort kchar) 17 (let ((roll (kern-dice-roll "1d20+4")) 18 (bonus (kern-dice-roll (string-append "1d" (number->string (occ-ability-thief kchar))))) 19 (finish-dc (* 2 dc)) 20 ) 21 ;; roll to complete 22 ;(println "complete: " roll "+" bonus " vs " finish-dc) 23 (if (or (= 20 roll) (> (+ roll bonus ) finish-dc)) 24 (let ((roll (kern-dice-roll "1d20")) 25 (bonus (kern-dice-roll (string-append "1d" (number->string (occ-ability-thief kchar))))) 26 ) 27 ;; roll to succeed 28 ;(println "succeed: " roll "+" bonus " vs " dc) 29 (cond ((or (= roll 20) (> (+ roll bonus ) dc)) 30 (send-signal kchar ktarg 'unlock) 31 (kern-char-task-end kchar) 32 ) 33 (else 34 (kern-log-msg "Picklock broke!") 35 (kern-obj-remove-from-inventory kchar t_picklock 1) 36 (kern-char-task-end kchar) 37 ) 38 ))))))) 39 40 41(mk-reusable-item 42 't_picklock "picklock" s_picklock norm 43 (lambda (kobj kuser) 44 (if (not (has-skill? kuser sk_unlock)) 45 result-lacks-skill 46 (let ((ktarg (ui-target (kern-obj-get-location kuser) 1 (mk-ifc-query 'unlock)))) 47 (cond ((null? ktarg) result-no-target) 48 (else 49 (kern-char-task-begin kuser "picking a lock" 'picklock-proc ktarg) 50 result-ok 51 )))))) 52 53;; gem -- use peer spell 54(mk-usable-item 't_gem "gem" s_gem norm 55 (lambda (kgem kuser) 56 (powers-view kuser kuser 12) 57 result-ok)) 58 59;; sledge-hammer -- shatter rocks 60(mk-reusable-item 't_pick "pick" s_pick v-hard 61 (lambda (ktool kuser) 62 (let ((loc (kern-ui-target (kern-obj-get-location kuser) 63 1))) 64 (if (null? loc) 65 result-no-target 66 (let ((kter (kern-place-get-terrain loc))) 67 (cond ((eqv? kter t_boulder) 68 (kern-log-msg (kern-obj-get-name kuser) 69 " pulverizes a boulder!") 70 (kern-place-set-terrain loc t_grass) 71 (cond ((> (kern-dice-roll "1d20") 16) 72 (kern-log-msg "The pick shatters!") 73 (kern-obj-remove-from-inventory kuser ktool 1))) 74 result-ok) 75 (else 76 result-no-effect))))))) 77 78;; sextant -- gives location 79(mk-reusable-item 't_sextant "sextant" s_sextant hard 80 (lambda (ktool kuser) 81 (let ((loc (kern-obj-get-location kuser))) 82 (cond ((kern-place-is-wilderness? (loc-place loc)) 83 (kern-log-msg "You are at [x=" 84 (cadr loc) " y=" (caddr loc) "]") 85 result-ok) 86 (else 87 (kern-log-msg "Usable only in the wilderness!") 88 result-not-here))))) 89 90;; ---------------------------------------------------------------------------- 91;; special object for testing multi-turn tasks 92(define (test-task-proc kchar) 93 (cond ((< (kern-dice-roll "1d20") 3) 94 (kern-char-task-end kchar) 95 #t 96 ) 97 (else 98 #t 99 ))) 100 101(mk-reusable-item 102 't_test_obj "test object" s_gem 0 103 (lambda (ktool kuser) 104 ;; test-task-proc must be passed in quotes or saving/reloading won't 105 ;; work. The kernel enforces this. The only legitimate reason for failure 106 ;; would be if the player is in the wilderness when he tries do to this, 107 ;; hence the result-not-here on failure (yeah, this is probably not a good 108 ;; assumption going forward). 109 (if (kern-char-task-begin kuser "a test task" 'test-task-proc nil) 110 result-ok 111 result-not-here) 112 )) 113 114;;---------------------------------------------------------------------------- 115;; shovel & buried object generator 116;;---------------------------------------------------------------------------- 117(define (buried-mk objtype-tag quan) (list objtype-tag quan)) 118(define (buried-objtype-tag buried) (car buried)) 119(define (buried-quan buried) (cadr buried)) 120 121(define (buried-digup kburied) 122 (display "buried-digup")(newline) 123 (let* ((buried (kobj-gob-data kburied)) 124 (kobj (kern-mk-obj (eval (buried-objtype-tag buried)) 125 (buried-quan buried)))) 126 (kern-obj-put-at kobj 127 (kern-obj-get-location kburied)) 128 (kern-log-msg "You dig up something!") 129 (kern-obj-remove kburied))) 130 131(define buried-ifc 132 (ifc nil 133 (method 'digup buried-digup))) 134 135(mk-obj-type 't_buried nil nil layer-none buried-ifc) 136 137(define (mk-buried objtype-tag quan) 138 (bind (kern-mk-obj t_buried 1) 139 (buried-mk objtype-tag quan))) 140 141(define (is-buried? kobj) 142 (eqv? (kern-obj-get-type kobj) 143 t_buried)) 144 145(mk-reusable-item 't_shovel "shovel" s_shovel v-hard 146 (lambda (kshovel kuser) 147 (let ((ktarg (filter is-buried? 148 (kern-get-objects-at 149 (kern-obj-get-location kuser))))) 150 (cond ((null? ktarg) 151 (kern-log-msg "Nothing buried here!") 152 result-no-effect) 153 (else 154 (signal-kobj (car ktarg) 'digup (car ktarg) nil) 155 result-ok))))) 156 157(mk-reusable-item 't_chrono "chronometer" s_chrono hard 158 (lambda (kclock kuser) 159 (let* ((time (kern-get-time)) 160 (hour (number->string 161 (if (< (time-hour time) 13) 162 (time-hour time) 163 (- (time-hour time) 12)))) 164 (minbase (number->string (time-minute time))) 165 (min (if (< (time-minute time) 10) 166 (string-append "0" minbase) 167 minbase))) 168 (kern-log-msg "The chronometer reads " hour ":" min) 169 result-ok))) 170 171(define clock-hand-icons (list s_clock_hand_n s_clock_hand_ne s_clock_hand_se s_clock_hand_s s_clock_hand_sw s_clock_hand_nw)) 172 173(define (clock-get-hand number) 174 (if (> number 5) 175 (clock-get-hand (- number 6)) 176 (list-ref clock-hand-icons number) 177 )) 178 179(define clock-ifc 180 (let ((readclock 181 (lambda (kclock kuser) 182 (let* ((time (kern-get-time)) 183 (hour (number->string 184 (if (< (time-hour time) 13) 185 (time-hour time) 186 (- (time-hour time) 12)))) 187 (minbase (number->string (time-minute time))) 188 (min (if (< (time-minute time) 10) 189 (string-append "0" minbase) 190 minbase))) 191 (kern-log-msg "The clock reads " hour ":" min) 192 result-ok)))) 193 (ifc '() 194 (method 'handle 195 readclock) 196 (method 'xamine 197 readclock) 198 (method 'step 199 (lambda (kmirror kuser) 200 )) 201 (method 'update-gfx 202 (lambda (kclock) 203 (let* ((time (kern-get-time)) 204 (hour-hand (clock-get-hand (floor (/ (time-hour time) 2)))) 205 (min-hand (clock-get-hand (floor (/ (+ (time-minute time) 5) 10))))) 206 (kern-obj-set-sprite kclock (mk-composite-sprite (list s_clock_body hour-hand min-hand))) 207 ))) 208 (method 'init 209 (lambda (kmirror) 210 (kern-obj-set-pclass kmirror pclass-wall) 211 )) 212 (method 'exec 213 (lambda (kclock) 214 (kern-sound-play-ambient sound-clock (kern-obj-get-location kclock)) 215 (let ( 216 (minute (time-minute (kern-get-time))) 217 (ticks (kern-time-get-remainder)) 218 ) 219 ;; TODO it may be possible to get this to work while loitering too 220 (if (and (equal? minute 0) (equal? ticks 0)) 221 (kern-sound-play-at sound-clock-chime (kern-obj-get-location kclock))) 222 ) 223 )) 224 (method 'on-entry 225 (lambda (kclock) 226 (kern-sound-play-ambient sound-clock (kern-obj-get-location kclock)) 227 )) 228 ))) 229 230(define broken-clock-ifc 231 (let ((readclock 232 (lambda (kclock kuser) 233 (kern-log-msg (gob kclock)) 234 ))) 235 (ifc '() 236 (method 'handle 237 readclock) 238 (method 'xamine 239 readclock) 240 (method 'step 241 (lambda (kmirror kuser) 242 )) 243 (method 'init 244 (lambda (kmirror) 245 (kern-obj-set-pclass kmirror pclass-wall) 246 )) 247 ))) 248 249(mk-obj-type 't_clock "clock" 250 (mk-composite-sprite (list s_clock_body s_clock_hand_n s_clock_spin)) 251 layer-mechanism clock-ifc) 252 253(define (mk-clock) 254 (let ((kclock (kern-mk-obj t_clock 1))) 255 (kern-obj-add-effect kclock ef_graphics_update nil) 256 (bind kclock nil) 257 kclock)) 258 259(mk-obj-type 't_broken_clock "clock" 260 s_clock_stopped 261 layer-mechanism broken-clock-ifc) 262 263(define (mk-broken-clock icona iconb message) 264 (let ((kclock (kern-mk-obj t_broken_clock 1))) 265 (bind kclock message) 266 (kern-obj-set-sprite kclock (mk-composite-sprite (list s_clock_stopped icona iconb))) 267 kclock)) 268 269 270(define (get-char-at location) 271 (define (get-char-from list) 272 (cond ((null? list) nil) 273 ((kern-obj-is-char? (car list)) (car list)) 274 (else (get-char-from (cdr list)))) 275 ) 276 (get-char-from (kern-get-objects-at location)) 277 ) 278 279;;------------------------------------------------ 280;; mirrors 281 282(define mirror-ifc 283 (ifc '() 284 (method 'handle 285 (lambda (kmirror kuser) 286 (kern-log-msg (kern-obj-get-name kuser) " spots " (kern-obj-get-name kuser) " in the mirror") 287 result-ok)) 288 (method 'step 289 (lambda (kmirror kuser) 290 )) 291 (method 'remote-sensor 292 (lambda (kmirror kuser) 293 (let* ((mirror-loc (kern-obj-get-location kmirror)) 294 (target-loc (list (car mirror-loc) (cadr mirror-loc) (+ (caddr mirror-loc) 1))) 295 (character (get-char-at target-loc))) 296 (if (null? character) 297 (kern-obj-set-sprite kmirror (mk-composite-sprite (list s_mirror_bg (eval (gob kmirror)) s_mirror_fg))) 298 (kern-obj-set-sprite kmirror (mk-composite-sprite (list s_mirror_bg (kern-obj-get-sprite character) (eval (gob kmirror)) s_mirror_fg)))) 299 (kern-map-set-dirty) 300 ))) 301 (method 'init 302 (lambda (kmirror) 303 (kern-obj-set-pclass kmirror pclass-wall) 304 )) 305 )) 306 307(mk-obj-type 't_mirror "mirror" 308 '() 309 layer-mechanism mirror-ifc) 310 311(define (mk-mirror background-tag) 312 (let ((kmirror (kern-mk-obj t_mirror 1))) 313 (bind kmirror background-tag) 314 (kern-obj-set-sprite kmirror (mk-composite-sprite (list s_mirror_bg (eval background-tag) s_mirror_fg))) 315 kmirror)) 316 317;;--------------------------------------------------------- 318;; bookshelf 319 320(define shelf-ifc 321 (ifc '() 322 (method 'step 323 (lambda (kobj kuser) 324 )) 325 (method 'init 326 (lambda (kobj) 327 (kern-obj-set-pclass kobj pclass-wall) 328 )) 329 )) 330 331(mk-obj-type 't_shelf "set of shelves" 332 s_bookshelf 333 layer-mechanism shelf-ifc) 334 335(define (mk-shelf) 336 (let ((kshelf (kern-mk-obj t_shelf 1))) 337 (bind kshelf nil) 338 kshelf)) 339 340;;--------------------------------------------------------- 341;; blocker 342 343(define blocker-ifc 344 (ifc '() 345 (method 'step 346 (lambda (kobj kuser) 347 )) 348 (method 'init 349 (lambda (kobj) 350 (kern-obj-set-pclass kobj pclass-space) 351 )) 352 )) 353 354(mk-obj-type 't_blocker nil 355 '() 356 layer-mechanism blocker-ifc) 357 358(define (mk-blocker) 359 (let ((kstop (kern-mk-obj t_blocker 1))) 360 (bind kstop nil) 361 kstop)) 362 363;; grease -- inert object, required for the Wriggle skill 364(mk-obj-type 't_grease "grease" s_grease layer-item obj-ifc) 365 366;;---------------------------------------------------------------------------- 367;; rope-and-hook -- use the wrogue's Reach skill. Works like telekineses but 368;; range is limited by wrogue ability. 369;; 370 371(mk-reusable-item 372 't_rope_hook "rope & hook" s_rope_hook hard 373 (lambda (kobj kuser) 374 (if (not (has-skill? kuser sk_reach)) 375 result-lacks-skill 376 (cast-ui-ranged-any (lambda (kchar ktarg power) 377 (cond ((not (check-roll dc-reach (occ-ability-thief kuser))) 378 (take kchar t_rope_hook 1) 379 (kern-obj-put-at (kern-mk-obj t_rope_hook 1) 380 (kern-obj-get-location ktarg)) 381 result-failed 382 ) 383 (else 384 ((kobj-ifc ktarg) 'handle ktarg kchar) 385 result-ok 386 ))) 387 kuser 388 (powers-telekinesis-range (occ-ability-thief kuser)) 389 (occ-ability-thief kuser) 390 kern-obj-is-mech?)))) 391