2 ;; init.scm -- contains lots of common scheme utilities
5 ;; Result codes (these belong here because they are tied to kernel values, see
8 (define result-no-target 1)
9 (define result-no-effect 2)
10 (define result-no-hostiles 3)
11 (define result-lacks-skill 4)
12 (define result-failed 5)
13 (define result-not-here 6)
14 (define result-critical-fail 7)
15 (define result-not-now 8)
17 ;; Test if a result code indicates that the action was not completed
18 (define (abortive-result? result)
19 (or (eq? result result-no-target)
20 (eq? result result-not-here)))
22 ;; Override the default error hook to warn the loader when the interpreter
23 ;; encounters any errors during evaluation.
24 (define (my-error-hook . x)
27 (define *error-hook* my-error-hook)
29 ;; kern-load -- loads a file but also tells the kernel to make a note of it so
30 ;; that saved sessions will know to use the file, too.
31 (define (kern-load fname)
37 ;; safe-eval -- evaluates an expression; bad expressions evaluate to '()
38 ;; instead of causing an interpreter error
39 (define (safe-eval expr)
40 (cond ((null? expr) '())
47 ;; filter -- filter-in elements from a list
48 (define (filter pred seq)
49 (cond ((null? seq) nil)
52 (filter pred (cdr seq))))
53 (else (filter pred (cdr seq)))))
55 ;; simple, non-prioritized, generic search (not very efficient, so don't try
56 ;; it on large search spaces)
57 (define (search here? next start maxdepth)
58 (define (do-search queue visited depth)
59 (if (or (= depth 0) (null? queue)) nil
60 (let ((loc (car queue)))
62 (do-search (append (cdr queue)
63 (filter (lambda (v) (not (member v visited)))
65 (append (list loc) visited)
67 (do-search (list start) nil maxdepth))
69 ;; similar to search, but a) it's exhaustive and b) it runs a procedure on
70 ;; every entry (warning: not sure if or how well this works)
71 (define (bfs-apply start next proc)
72 (define (do-search queue visited)
74 (let ((loc (car queue)))
76 (do-search (append (cdr queue)
77 (filter (lambda (v) (not (member v visited)))
79 (append (list loc) visited)))))
80 (do-search (list start) nil))
82 ;; Set element k of list x to val (zero-indexed)
83 (define (list-set-ref! x k val)
86 (list-set-ref! (cdr x) (- k 1) val)))
88 ;; Check if a list contains an element.
89 (define (in-list? elem lst)
90 (foldr (lambda (a b) (or a (eqv? b elem)))
94 (define (in-text-list? elem lst)
95 (foldr (lambda (a b) (or a (equal? b elem)))
99 ;; Check if a location is passable to a character
100 (define (passable? loc kobj)
101 (kern-place-is-passable loc kobj))
103 (define (obj-is-char? kobj) (kern-obj-is-being? kobj))
104 (define (is-being? kobj) (kern-obj-is-being? kobj))
106 ;; Check if a location is occupied by a character or party
107 (define (occupied? loc)
108 (foldr (lambda (val kobj) (or val (obj-is-char? kobj)))
110 (kern-get-objects-at loc)))
112 (define (get-beings-at loc)
113 (filter kern-obj-is-being?
114 (kern-get-objects-at loc)))
116 ;; Given a starting location, search outward for a passable, unoccupied place
117 ;; to put a character.
118 (define (pick-loc origin char)
119 (search (lambda (loc) (and (kern-is-valid-location? loc)
121 (not (occupied? loc))))
126 ;; Generic proc to summon other beings. Used by spells and some special
128 (define (summon origin mk-critter faction count)
131 (let* ((critter (kern-obj-set-temporary (kern-being-set-base-faction
135 (loc (pick-loc origin critter)))
136 (cond ((null? loc) nil)
138 (kern-obj-put-at critter loc)
139 (run-loop (- n 1)))))))
142 ;; Like summon but the beings are permanent, not temporary.
143 (define (psummon origin mk-critter count)
144 ;;;(display "psummon")(newline)
147 (let* ((critter (kern-obj-inc-ref (mk-critter)))
148 (loc (pick-loc origin critter)))
149 (cond ((null? loc) (kern-obj-dec-ref critter))
151 (kern-obj-put-at critter loc)
152 (kern-obj-dec-ref critter)
153 (run-loop (- n 1)))))))
156 ;; check if klooker can see kobj
157 (define (can-see? klooker kobj)
158 (let ((from (kern-obj-get-location klooker))
159 (to (kern-obj-get-location kobj)))
160 (and (kern-in-los? from to)
161 (<= (kern-get-distance from to)
162 (kern-obj-get-vision-radius klooker))
163 (kern-obj-is-visible? kobj))))
165 ;; check if klooker can can see anything in the list kobs
166 (define (can-see-any? klooker kobjs)
169 (or (can-see? klooker (car kobjs))
170 (can-see-any? klooker (cdr kobjs)))))
172 ;; check if knpc can see any of the player party members
173 (define (any-player-party-member-visible? knpc)
175 (kern-party-get-members (kern-get-player))))
177 ;; gets location of player character (not party- ie 'works' in temporary map)
178 (define (player-member-loc)
179 (let ((loc (kern-obj-get-location (car (kern-party-get-members (kern-get-player))))))
184 (define (num-player-party-members)
185 ;;(display "num-player-party-members")(newline)
186 (length (kern-party-get-members (kern-get-player))))
188 (define (is-only-living-party-member? kchar)
189 (and (is-alive? kchar)
190 (is-player-party-member? kchar)
191 (not (foldr (lambda (found kchar2)
192 (println found " " (kern-obj-get-name kchar2))
194 (and (not (eqv? kchar kchar2))
195 (is-alive? kchar2))))
197 (kern-party-get-members (kern-get-player))))
200 ;; Check if an object is hostile toward a character
201 (define (is-hostile? kbeing kobj)
202 (and (is-being? kobj)
203 (kern-being-is-hostile? kbeing kobj)))
205 ;; Check if an object is allied with a character
206 (define (is-ally? kbeing kobj)
207 (kern-being-is-ally? kbeing kobj))
209 ;; Find all characters hostile to the given character
210 (define (all-hostiles kchar)
211 (filter (lambda (kobj) (is-hostile? kchar kobj))
212 (kern-place-get-beings (loc-place (kern-obj-get-location kchar)))))
214 ;; Find all friendlies
215 (define (all-allies kchar)
216 (filter (lambda (kobj) (is-ally? kchar kobj))
217 (kern-place-get-beings (loc-place (kern-obj-get-location kchar)))))
220 ;; Count the number of hostiles
221 (define (num-hostiles kchar)
222 (length (all-hostiles kchar)))
224 ;; Count the number of friendlies
225 (define (num-allies kchar)
226 (length (all-allies kchar)))
228 ;; Find all beings hostile
229 (define (all-visible-hostiles kbeing)
230 (kern-being-get-visible-hostiles kbeing))
232 (define (any-visible-hostiles? kchar)
233 (> (length (all-visible-hostiles kchar)) 0))
235 (define (nearest-visible-hostile kchar)
236 (nearest-obj kchar (all-visible-hostiles kchar)))
239 (define (all-visible-allies kbeing)
240 (kern-being-get-visible-allies kbeing))
242 ;; Count the number of visible friendlies
243 (define (num-visible-allies kchar)
244 (length (all-visible-allies kchar)))
246 ;; Count the number of hostiles
247 (define (num-visible-hostiles kchar)
248 (length (all-visible-hostiles kchar)))
251 ;; Find all the characters in a place
252 (define (all-chars kplace)
253 (kern-place-get-beings kplace))
255 ;; Check if an object is in the given range of the origin point
256 (define (in-range? origin radius kobj)
257 (<= (kern-get-distance origin
258 (kern-obj-get-location kobj))
261 ;; Check if a character's target is in range
262 (define (can-hit? kchar ktarg range)
263 ;;(println "can-hit: " range)
264 (in-range? (kern-obj-get-location kchar)
268 ;; Filter objects out of range
269 (define (all-in-range origin radius objlst)
270 (filter (lambda (kobj)
271 (<= (kern-get-distance origin
272 (kern-obj-get-location kobj))
276 ;; Return a list of all hostiles in range of the given location
277 (define (get-hostiles-in-range-of-loc kchar range loc)
280 (kern-being-get-visible-hostiles kchar)))
282 ;; Return a list of all hostiles in range of the kchar's current location
283 (define (get-hostiles-in-range kchar range)
284 (get-hostiles-in-range-of-loc kchar
286 (kern-obj-get-location kchar)))
288 ;; Return a list of beings within the given range
289 (define (get-beings-in-range kobj range)
290 (let ((loc (kern-obj-get-location kobj)))
293 (kern-place-get-beings (loc-place loc)))))
295 ;; Convenience proc for rolling dtables by hand
296 (define (dtable-row . cols) cols)
298 (define (distance kobj-a kobj-b)
299 (let ((loc-a (kern-obj-get-location kobj-a))
300 (loc-b (kern-obj-get-location kobj-b)))
301 (kern-get-distance loc-a loc-b)))
303 ;; Inefficient code to find nearest obj from a list
304 (define (nearest-obj kobj klist)
305 (if (null? klist) nil
306 (foldr (lambda (a b) (if (< (distance kobj a) (distance kobj b)) a b))
307 (car klist) (cdr klist))))
309 ;; Inefficient code to find nearest location from a list
310 (define (nearest-loc kobj klist)
311 (println "nearest-loc: " klist)
314 (let ((kloc (kern-obj-get-location kobj)))
316 (if (< (loc-city-block-distance kloc a)
317 (loc-city-block-distance kloc b))
323 ;; Move an object one step along a path to a destination.
324 (define (old-pathfind kobj dest)
325 ;;;;(display "pathfind")(newline)
326 (define (follow-path path)
327 (if (not (null? path))
328 (let ((coords (car path))
329 (origin (kern-obj-get-location kobj)))
330 ;;;;(display "pathfind:coords=");;(display coords)(newline)
331 (let ((dx (- (car coords) (loc-x origin)))
332 (dy (- (cdr coords) (loc-y origin))))
333 (kern-obj-move kobj dx dy)))))
334 (let ((path (kern-obj-find-path kobj dest)))
335 ;;;;(display "pathfind:path=");;(display path)(newline)
336 (if (not (null? path))
337 ;; skip the first location in the path
338 (follow-path (cdr path)))))
340 ;; pathfind - use the built-in kernel call that uses cached paths and tries to
341 ;; handle blocking mechanisms
342 (define (pathfind kobj kdest)
343 ;;(println "pathfind(" (kern-obj-get-name kobj) "," kdest ")")
344 (and (kern-obj-is-being? kobj)
345 (kern-being-pathfind-to kobj kdest)))
347 (define (can-pathfind? kobj dest)
348 (println "can-pathfind?")
349 (or (loc-8-adjacent? dest
350 (kern-obj-get-location kobj))
351 (not (null? (kern-obj-find-path kobj dest)))))
353 (define (notnull? val) (not (null? val)))
355 (define (being-at? loc)
356 (not (null? (filter kern-obj-is-being? (kern-get-objects-at loc)))))
358 (define (get-being-at loc)
359 (let ((beings (filter kern-obj-is-being? (kern-get-objects-at loc))))
364 (define (is-dead? kchar)
365 (kern-char-is-dead? kchar))
367 (define (is-alive? kchar)
368 (not (is-dead? kchar)))
370 (define (has-ap? kobj)
371 (> (kern-obj-get-ap kobj) 0))
373 (define (has-ap-debt? kobj)
374 (< (kern-obj-get-ap kobj) 0))
376 (define (has-skill? kchar kskill)
378 (kern-char-get-skills kchar)))
381 ;;;(display "flee")(newline)
382 (kern-char-set-fleeing kchar #t))
384 (define (wander kchar)
385 (kern-obj-wander kchar))
387 (define (weakest kchar-a kchar-b)
388 (if (< (kern-char-get-hp kchar-a)
389 (kern-char-get-hp kchar-b))
393 (define (join-player kchar)
394 (kern-char-join-player kchar))
396 (define (random-select list)
400 (list-ref list (modulo (random-next) (length list)))))
402 (define (taunt kchar ktarg taunts)
403 (say kchar (random-select taunts)))
405 ;; ----------------------------------------------------------------------------
406 ;; search-rect -- apply a procedure to every location in a rectangular region
407 ;; and return a list of its non-nil results.
408 ;; ----------------------------------------------------------------------------
409 (define (search-rect kplace x y w h proc)
410 (filter notnull? (map proc (loc-enum-rect kplace x y w h))))
412 ;; ----------------------------------------------------------------------------
413 ;; foldr-rect -- similar to search-rect above, but the procedure must
414 ;; accumulate its own results. Faster because it doesn't have to run the
416 ;; ----------------------------------------------------------------------------
417 (define (foldr-rect kplace x y w h proc ival)
418 (foldr proc ival (loc-enum-rect kplace x y w h)))
420 ;;----------------------------------------------------------------------------
421 ;; Return a list of locations with matching terrain
422 ;;----------------------------------------------------------------------------
423 (define (find-terrain kplace x y w h kter)
425 (if (eqv? (kern-place-get-terrain loc) kter)
428 (search-rect kplace x y w h check))
430 (define (on-terrain? kobj kter)
431 (eqv? kter (kern-place-get-terrain (kern-obj-get-location kobj))))
433 (define (all-visible-terrain-of-type kobj kter)
436 (kern-place-get-terrain x)))
437 (kern-being-get-visible-tiles kobj)))
439 (define (find-nearest-visible-terrain-of-type kobj kter)
440 (nearest-loc kobj (all-visible-terrain-of-type kobj kter)))
442 (define (hidden? kchar)
443 ;;(println "hidden?")
444 ;; Just check if the 8 neighbors are all los-blocking
445 (let ((loc (kern-obj-get-location kchar)))
446 (foldr-rect (loc-place loc)
447 (- (loc-x loc) 1) (- (loc-y loc) 1)
449 (lambda (val neighbor)
450 ;;(println neighbor " neighbor? " (equal? neighbor loc) " blocks? " (kern-place-blocks-los? neighbor))
452 (or (eq? neighbor loc)
453 (kern-place-blocks-los? neighbor))))
457 ;; kobj-is-type -- check if the object is of the given type
458 (define (kobj-is-type? kobj ktype)
459 (eqv? (kern-obj-get-type kobj)
462 ;; kplace-get-objects-of-type -- return a list of all objects of the given type
463 ;; in the given place
464 (define (kplace-get-objects-of-type kplace ktype)
465 (filter (lambda (kobj) (kobj-is-type? kobj ktype))
466 (kern-place-get-objects kplace)))
468 ;;----------------------------------------------------------------------------
469 ;; find-objects -- return a list of locations with the given object on them
470 ;;----------------------------------------------------------------------------
471 (define (find-objects kplace x y w h ktype)
473 (define (scanobjlst lst)
475 (or a (kobj-is-type? b ktype)))
478 (if (scanobjlst (kern-get-objects-at loc))
481 (search-rect kplace x y w h check))
483 (define (in-inventory? kchar ktype)
484 ;;(println (kern-type-get-name ktype))
485 (define (hasit? item inv)
486 (cond ((null? inv) #f)
487 ((eqv? item (car (car inv))) #t)
489 ;;(println " " (kern-type-get-name (car (car inv))))
490 (hasit? item (cdr inv)))))
491 (hasit? ktype (kern-char-get-inventory kchar)))
493 (define (num-in-inventory kchar ktype)
494 (define (count-em item inv)
495 ;;;(display "inv: ");;(display inv)(newline)
496 (cond ((null? inv) 0)
497 ((eqv? item (car (car inv))) (cdr (car inv)))
498 (else (count-em item (cdr inv)))))
499 (count-em ktype (kern-char-get-inventory kchar)))
501 (define (any-in-inventory? kchar lst)
504 (in-inventory? kchar k)))
508 (define (all-in-inventory? kchar lst)
511 (in-inventory? kchar k)))
515 ;; Note: I commented out the remove-from-inventory call because the things
516 ;; should remove themselves (eg, potions do)
517 (define (use-item-from-inventory-on-self kchar ktype)
518 ;;(kern-obj-remove-from-inventory kchar ktype 1)
519 ;;;(display "using")(newline)
520 (apply (kern-type-get-gifc ktype) (list 'use ktype kchar))
521 (kern-log-msg (kern-obj-get-name kchar)
523 (kern-type-get-name ktype))
526 ;;============================================================================
527 ;; Modulo system procedures -- useful on wrapping maps
528 ;;============================================================================
529 (define (madd a b R) (modulo (+ a b) R))
530 (define (msub a b R) (modulo (- a b) R))
531 (define (minc a R) (modulo (+ a 1) R))
532 (define (mdec a R) (modulo (- a 1) R))
534 ;;----------------------------------------------------------------------------
535 ;; mdist - find the distance between two numbers in a modulo system. There are
536 ;; always 2 distances (additive and subtractive). This picks the shortest
538 ;;----------------------------------------------------------------------------
539 (define (mdist a b R) (min (msub a b R) (msub b a R)))
541 ;; ----------------------------------------------------------------------------
542 ;; Turn on/off verbose scheme garbage collection. Useful if you think scheme is
543 ;; gc'ing some of your code behind your back.
544 ;; ----------------------------------------------------------------------------
547 (define (profile proc . args)
548 (let ((t (kern-get-ticks))
549 (result (apply proc args)))
550 ;;(display "*** TIME: ");;(display (- (kern-get-ticks) t)) ;;(display " ms")
554 ;; ----------------------------------------------------------------------------
555 ;; find-object-types-at -- return a list of objects of the given type which can
556 ;; be found at the given location
557 ;; ----------------------------------------------------------------------------
558 (define (find-object-types-at loc ktype)
559 (filter (lambda (a) (kobj-is-type? a ktype))
560 (kern-get-objects-at loc)))
562 ;; ----------------------------------------------------------------------------
563 ;; is-object-type-at? -- check for an object (by type) at a location
564 ;; ----------------------------------------------------------------------------
565 (define (is-object-type-at? loc ktype)
566 (foldr (lambda (a b) (or a (kobj-is-type? b ktype)))
568 (kern-get-objects-at loc)))
570 ;; ----------------------------------------------------------------------------
571 ;; any-object-types-at? -- returns #t iff one or more objects at loc is of one
572 ;; of the given types
573 ;; ----------------------------------------------------------------------------
574 (define (any-object-types-at? loc ktypes)
575 (foldr (lambda (a b) (or a (is-object-type-at? loc b)))
579 ;; is-player-party-member? -- #t iff kchar is in player party
580 (define (is-player-party-member? kchar)
582 (kern-party-get-members (kern-get-player))))
584 ;; ----------------------------------------------------------------------------
585 ;; kobj-get -- remove an object from the map and put it into another object
586 ;; ----------------------------------------------------------------------------
587 (define (kobj-get kobj kchar)
588 (if (kern-obj-put-into kobj kchar)
590 (if (not (is-player-party-member? kchar))
591 (kern-log-msg (kern-obj-get-name kchar)
593 (kern-obj-get-name kobj)))
594 (kern-obj-inc-ref kobj)
595 (kern-obj-remove kobj)
596 (kern-obj-dec-ref kobj)
597 (kern-obj-dec-ap kchar (/ norm 5))
598 (kern-map-repaint))))
600 ;; ----------------------------------------------------------------------------
601 ;; kobj-get-at -- get an object of a specific type from the location
602 ;; ----------------------------------------------------------------------------
603 (define (kobj-get-at kchar loc ktype)
604 (let ((objs (find-object-types-at loc ktype)))
606 (kobj-get (car objs) kchar))))
608 ;; ----------------------------------------------------------------------------
609 ;; place-random-corner -- randomly select a corner and return it as a location
610 ;; ----------------------------------------------------------------------------
611 (define (place-random-corner kplace)
612 (case (kern-dice-roll "1d4")
613 ((1) (mk-loc kplace 0 0))
614 ((2) (mk-loc kplace 0 (- (kern-place-get-width kplace 1))))
615 ((3) (mk-loc kplace (- (kern-place-get-height kplace) 1) 0))
617 (- (kern-place-get-height kplace) 1)
618 (- (kern-place-get-width kplace) 1)))))
620 ;; ----------------------------------------------------------------------------
621 ;; do-or-goto -- if the location is adjacent then the proc, otherwise have
622 ;; the char pathfind to it
623 ;; ----------------------------------------------------------------------------
624 (define (do-or-goto kchar coords proc)
625 ;;;(display "do-or-goto")(newline)
626 (if (or (loc-4-adjacent? (kern-obj-get-location kchar) coords)
627 (eq? coords (kern-obj-get-location kchar)))
629 (pathfind kchar coords)))
631 ;; ----------------------------------------------------------------------------
632 ;; evade -- simple alg for evading melee foes
634 ;; Simple approach: each foe's coordinates forms a vector to the char's
635 ;; coordinates. Take the sum of these coordinates to get the evasion
636 ;; vector. "Normalize" the vector components by rounding them to the nearest 0,
637 ;; 1 or -1. This is the dx/dy to move. If the terrain is impassable in the
638 ;; preferred direction then try zeroing out the non-zero components and
639 ;; moving. This will give two backup vectors to try.
641 ;; ADDENDUM: I don't want to allow diagonal evasion, so the "normalized" vector
642 ;; must be skipped if it's a diagonal, thus causing us to try the fallbak
645 ;; Now allowing diagonals, since that factor has changed
647 ;; TODO: probably shouldnt flee over dangerous terrains
649 ;; ----------------------------------------------------------------------------
650 (define (evade kchar foes)
651 (let* ((tloc (kern-obj-get-location kchar))
654 (lambda (accum thisfoe)
656 (loc-diff (kern-obj-get-location thisfoe) tloc)
658 (mk-loc (loc-place tloc) 0 0)
663 (if (kern-place-is-passable
665 (mk-loc (loc-place tloc) dx dy)
668 (kern-obj-move kchar dx dy)
670 (define (evade-on-normal)
671 (move (loc-x v) (loc-y v)))
673 (or (evade-on-normal)
674 (and (not (eq? 0 (loc-y v)))
676 (and (not (eq? 0 (loc-x v)))
681 ;; ----------------------------------------------------------------------------
682 ;; closest-obj -- given an origin and a list of objects, return the object from
683 ;; the list that is closest (in city-block distance) to the origin
684 ;; ----------------------------------------------------------------------------
685 (define (closest-obj origin lst)
688 (if (loc-closer? (kern-obj-get-location a)
689 (kern-obj-get-location b)
696 ;; ----------------------------------------------------------------------------
697 ;; blit-maps -- blit multiple maps to a single target map
698 ;; ---------------------------------------------------------------------------
699 (define (blit-maps kmap . blits)
700 (define (blit dstx dsty srcmap srcx srcy w h)
701 (kern-blit-map kmap dstx dsty srcmap srcx srcy w h))
702 (foldr (lambda (a b) (apply blit b))
706 (define (fill-terrain-prob kter kplace ox oy ow oh prob)
707 (define (fill x y w h)
711 (if (<= (modulo (random-next)
714 (kern-place-set-terrain (list kplace x y) kter))
715 (fill (+ x 1) y (- w 1) h))
716 (fill ox (+ y 1) ow (- h 1)))))
719 (define (fill-terrain kter kplace ox oy ow oh)
720 (fill-terrain-prob kter kplace ox oy ow oh 100))
722 ;;============================================================================
724 ;;============================================================================
725 (define (mk-rect x y w h) (list x y w h))
726 (define (rect-x r) (car r))
727 (define (rect-y r) (cadr r))
728 (define (rect-w r) (caddr r))
729 (define (rect-h r) (cadddr r))
730 (define (rect-ex r) (+ (rect-x r) (rect-w r)))
731 (define (rect-ey r) (+ (rect-y r) (rect-h r)))
732 (define (x-in-rect? x r)
733 (and (>= x (rect-x r))
735 (define (y-in-rect? y r)
736 (and (>= y (rect-y r))
738 (define (xy-in-rect? x y r)
739 (and (x-in-rect? x r)
741 (define (rect-in-rect? a b)
742 (and (xy-in-rect? (rect-x a) (rect-y a) b)
743 (xy-in-rect? (rect-ex a) (rect-ey a) b)))
744 (define (loc-in-rect? loc rect)
745 (xy-in-rect? (loc-x loc)
748 (define (rect-random rect)
749 (list (+ (rect-x rect) (modulo (random-next) (rect-w rect)))
750 (+ (rect-y rect) (modulo (random-next) (rect-h rect)))))
752 ;;;; (define original-load load)
753 ;;;; (define (load file)
754 ;;;; (display (kern-get-ticks))
755 ;;;; (display " loading ")
756 ;;;; (display file)(newline)
757 ;;;; (original-load file))
759 (define (put obj x y) (list obj x y))
761 ;; lookup-spell-by-handler -- find a spell in the list of all spells
762 (define (lookup-spell handler)
763 (define (search-spells slist)
766 (let ((spell (car slist)))
767 (if (eqv? (spell-handler spell)
770 (search-spells (cdr slist))))))
771 (search-spells spells))
774 (define (lookup this? slist)
777 (if (this? (car slist))
779 (lookup this? (cdr slist)))))
781 ;; can-cast -- check if a char has enough mana to cast a spell
782 (define (can-cast? kchar handler)
783 (let ((spell (lookup-spell handler)))
786 (and (>= (kern-char-get-mana kchar)
788 (>= (kern-char-get-level kchar)
789 (spell-level spell))))))
791 ;; cast0 - cast a spell which requires no args if possible, assumes kchar has
793 (define (cast0 kchar spell)
794 (apply (spell-handler spell) (list kchar))
795 (kern-char-dec-mana kchar (spell-cost spell))
796 (kern-obj-dec-ap kchar (spell-ap spell))
797 (kern-log-msg (kern-obj-get-name kchar)
801 ;; cast1 - cast a spell which requires one arg if possible, assumes kchar has
803 (define (cast1 kchar spell ktarg)
804 ;;;(display "cast1: ");;(display spell)(newline)
805 (apply (spell-handler spell) (list kchar ktarg))
806 (kern-char-dec-mana kchar (spell-cost spell))
807 (kern-obj-dec-ap kchar (spell-ap spell))
808 (kern-log-msg (kern-obj-get-name kchar)
812 (kern-obj-get-name ktarg)
815 ;; ----------------------------------------------------------------------------
816 ;; terrain-ok-for-field? -- check if the terrain at a given location will allow
817 ;; a field to be dropped on it. Terrains with passability class equivalent to
818 ;; Grass, trees and forest are ok, everything else is not.
819 ;; ----------------------------------------------------------------------------
820 (define (terrain-ok-for-field? loc)
821 (let ((kter (kern-place-get-terrain loc)))
822 (println "kter: " kter)
825 (let ((pclass (kern-terrain-get-pclass kter)))
826 (foldr (lambda (a b) (or a (= pclass b)))
828 (list pclass-grass pclass-trees pclass-forest))))))
830 (define (get-8-neighboring-tiles loc)
831 (let ((kplace (loc-place loc))
834 (filter kern-is-valid-location?
835 (map (lambda (offset) (mk-loc kplace
847 (define (get-4-neighboring-tiles loc)
848 (let ((kplace (loc-place loc))
851 (filter kern-is-valid-location?
852 (map (lambda (offset) (mk-loc kplace
861 (define (shake-map dur)
864 (kern-map-set-jitter #t)
866 (shake-map (- dur 1)))
868 (kern-map-set-jitter #f)
869 (kern-map-repaint))))
871 (define (random-vdir)
872 (random-select (list (cons -1 0)
877 (define (random-neighbor-loc kobj)
878 (let ((vdir (random-vdir)))
879 (loc-sum (kern-obj-get-location kobj)
880 (mk-loc nil (car vdir) (cdr vdir)))))
882 (define (push kobj dx dy dist)
883 (let* ((loc (loc-sum (kern-obj-get-location kobj)
884 (mk-loc nil dx dy))))
885 (if (and (kern-place-is-passable loc kobj)
886 (not (occupied? loc)))
888 (kern-obj-relocate kobj loc nil)
892 (define (stagger kchar)
893 (let ((vdir (random-vdir)))
894 (push kchar (car vdir) (cdr vdir) 1)))
896 (define (end-turn kobj)(kern-obj-set-ap kobj 0))
898 (define (add-effect-multiple kobj keff fgob q)
901 (kern-obj-add-effect kobj keff fgob)
902 (add-effect-multiple kobj keff fgob (- q 1)))))
904 ;; time procs for use with return value from kern-get-time:
905 (define (time-mk yr mo we da hr mi)
906 (list yr mo we da hr mi))
907 (define (time-year time) (list-ref time 0))
908 (define (time-month time) (list-ref time 1))
909 (define (time-week time) (list-ref time 2))
910 (define (time-day time) (list-ref time 3))
911 (define (time-hour time) (list-ref time 4))
912 (define (time-minute time) (list-ref time 5))
914 ;; wants-healing? -- check if a char is <= 50% max hp
915 (define (wants-healing? kchar)
916 (<= (kern-char-get-hp kchar)
917 (/ (kern-char-get-max-hp kchar) 2)))
919 ;; wants-healing? -- check if a char is <= 25% max hp
920 (define (wants-great-healing? kchar)
921 (<= (kern-char-get-hp kchar)
922 (/ (kern-char-get-max-hp kchar) 4)))
924 ;; wants-mana? -- check if a char is <= 50% max mana
925 (define (wants-mana? kchar)
926 (<= (kern-char-get-mana kchar)
927 (/ (kern-char-get-max-mana kchar) 2)))
929 ;; has-mana-potion? -- check if a char has a mana potion in inventory
930 (define (has-mana-potion? kchar)
931 (in-inventory? kchar t_mana_potion))
933 ;; drink-mana-potion -- use a mana potion from inventory
934 (define (drink-mana-potion kchar)
935 (use-item-from-inventory-on-self kchar t_mana_potion))
937 ;; has-heal-potion? -- check if a char has a heal potion in inventory
938 (define (has-heal-potion? kchar)
939 (in-inventory? kchar t_heal_potion))
941 ;; drink-heal-potion -- use a heal potion from inventory
942 (define (drink-heal-potion kchar)
943 (use-item-from-inventory-on-self kchar t_heal_potion))
945 (define (set-max-hp kchar)
946 (kern-char-set-hp kchar
947 (kern-char-get-max-hp kchar)))
949 ;; max-hp -- calc max hp given species, level and occ
950 (define (max-hp sp occ lvl mod mult)
951 (+ (kern-species-get-hp-mod sp)
952 (if (null? occ) 0 (kern-occ-get-hp-mod occ))
955 (+ (kern-species-get-hp-mult sp)
956 (if (null? occ) 0 (kern-occ-get-hp-mult occ))
959 ;; max-mp -- calc max mp given species, level and occ
960 (define (max-mp sp occ lvl mod mult)
961 (+ (kern-species-get-mp-mod sp)
962 (if (null? occ) 0 (kern-occ-get-mp-mod occ))
965 (+ (kern-species-get-mp-mult sp)
966 (if (null? occ) 0 (kern-occ-get-mp-mult occ))
970 ;; set-level -- set character to level and max out hp and mana (intended for
972 (define (set-level kchar lvl)
973 (kern-char-set-level kchar lvl))
975 ;; use-potion? -- use potion on self if desired and available
976 (define (use-potion? kchar)
977 (or (and (wants-healing? kchar)
978 (has-heal-potion? kchar)
979 (drink-heal-potion kchar))
980 (and (wants-mana? kchar)
981 (has-mana-potion? kchar)
982 (drink-mana-potion kchar))))
984 (define (use-heal-spell-on-self? kchar)
985 ;;;;(display "use-heal-spell-on-self?")(newline)
986 (and (wants-healing? kchar)
987 (can-use-ability? heal-ability kchar)
988 (use-ability heal-ability kchar kchar)))
990 (define (use-great-heal-spell-on-self? kchar)
991 ;;;;(display "use-great-heal-spell-on-self?")(newline)
992 (and (wants-great-healing? kchar)
993 (can-use-ability? great-heal-ability kchar)
994 (use-ability great-heal-ability kchar kchar)))
996 (define (use-spell-on-self? kchar)
997 ;;;;(display "use-spell-on-self?")(newline)
998 (or (use-great-heal-spell-on-self? kchar)
999 (use-heal-spell-on-self? kchar)))
1001 (define (avoid-melee? kchar)
1002 ;;;;(display "avoid-melee? kchar")(newline)
1003 (let ((nearby-foes (get-hostiles-in-range kchar 1)))
1004 (if (null? nearby-foes)
1006 (evade kchar nearby-foes))))
1008 (define (dump-char kchar)
1012 (println "npc: " (kern-obj-get-name kchar)
1013 "[" (kern-char-get-level kchar) "]"
1014 " hp=" (kern-char-get-hp kchar) "/" (kern-char-get-max-hp kchar)
1015 " mp=" (kern-char-get-mana kchar) "/" (kern-char-get-max-mana kchar)
1016 " @[" (loc-x (kern-obj-get-location kchar))
1017 "," (loc-y (kern-obj-get-location kchar)) "]"
1021 (define (get-nearest-patient kchar)
1022 (let ((kloc (kern-obj-get-location kchar)))
1023 (foldr (lambda (kpatient ktarg)
1024 ;;(display " checking ")(dump-char ktarg)
1025 (if (and (wants-healing? ktarg)
1026 (or (null? kpatient)
1027 (< (kern-get-distance kloc
1028 (kern-obj-get-location ktarg))
1029 (kern-get-distance kloc
1030 (kern-obj-get-location kpatient)))))
1034 (all-visible-allies kchar))))
1036 ;; This is for medics. A patient is an ally that needs healing. If a patient is
1037 ;; less than 2 tiles away then do nothing. If a patient is more than 2 tiles
1038 ;; away then pathfind toward it.
1039 (define (move-toward-patient? kchar)
1040 (let ((patient (get-nearest-patient kchar)))
1044 ;;(display "selected ")(dump-char patient)
1045 (if (in-range? (kern-obj-get-location kchar)
1049 (pathfind kchar (kern-obj-get-location patient)))))))
1051 (define (prompt-for-key)
1052 (kern-log-msg "<Hit any key to continue>")
1055 (define (ship-at? loc) (not (null? (kern-place-get-vehicle loc))))
1057 (define (take-player-gold q)
1058 (kern-player-set-gold (- (kern-player-get-gold) q)))
1060 (define (give-player-gold q)
1061 (kern-player-set-gold (+ (kern-player-get-gold) q)))
1063 (define (player-has-gold? q)
1064 (>= (kern-player-get-gold) q))
1066 ;; services -- used with trade-service below
1067 (define (svc-mk name price proc) (list name price proc))
1068 (define (svc-name svc) (car svc))
1069 (define (svc-price svc) (cadr svc))
1070 (define (svc-proc svc) (caddr svc))
1072 ;; some standard healer services
1073 (define (heal-service kchar knpc)
1074 ;;(display "heal-service")(newline)
1075 (let ((hp (- (kern-char-get-max-hp kchar)
1076 (kern-char-get-hp kchar))))
1079 (say knpc "VAS MANI! Be healed, "
1080 (kern-obj-get-name kchar))
1082 (kern-obj-heal kchar hp)
1085 (say knpc (kern-obj-get-name kchar)
1090 (define (cure-service kchar knpc)
1091 ;;(display "cure-service")(newline)
1092 (if (is-poisoned? kchar)
1094 (say knpc "AN NOX! You are cured, "
1095 (kern-obj-get-name kchar))
1097 (kern-obj-remove-effect kchar ef_poison))
1099 (say knpc (kern-obj-get-name kchar)
1100 " is not poisoned!")
1104 (define (resurrect-service kchar knpc)
1105 ;;(display "resurrect-service")(newline)
1106 (if (is-dead? kchar)
1108 (say knpc "IN MANI CORP! Arise, "
1109 (kern-obj-get-name kchar))
1110 (kern-map-flash 500)
1112 (kern-obj-heal kchar 10))
1114 (say knpc (kern-obj-get-name kchar)
1119 ;; trade-services -- take a list of services which operate on a party member
1120 ;; and prompt the player, check prices, and otherwise handle the transaction
1121 (define (trade-services knpc kpc services)
1123 (define (list-services)
1125 (string-append (svc-name svc)
1127 (number->string (svc-price svc))
1131 ;; line-name - convert a string like "Heal...30 gold" to "Heal"
1132 (define (line-name line)
1136 (if (char=? (car l) #\.)
1138 (cons (car l) (extract (cdr l))))))
1141 (list->string (extract (string->list line)))))
1143 (define (lookup-svc line)
1144 (let ((name (line-name line)))
1147 (lookup (lambda (svc)
1152 (define (choose-svc)
1153 (lookup-svc (apply kern-ui-select-from-list (list-services))))
1155 (let ((svc (choose-svc)))
1158 (if (player-has-gold? (svc-price svc))
1161 (say knpc "You don't have enough gold!")
1165 (let ((kchar (kern-ui-select-party-member)))
1168 (if (apply (svc-proc svc) (list kchar knpc))
1170 (take-player-gold (svc-price svc))
1173 (and (not (null? svc))
1177 ;; player-out-of-sight -- no LOS between kobj and any party member
1178 (define (player-out-of-sight? kobj)
1179 (define (can-see? members)
1182 (or (kern-in-los? (kern-obj-get-location (car members))
1183 (kern-obj-get-location kobj))
1184 (can-see? (cdr members)))))
1185 (not (can-see? (kern-party-get-members (kern-get-player)))))
1187 (define (improve-relations kb1 kb2)
1188 (kern-dtable-inc (kern-being-get-current-faction kb1)
1189 (kern-being-get-current-faction kb2)))
1191 (define (harm-relations kb1 kb2)
1192 (kern-dtable-dec (kern-being-get-current-faction kb1)
1193 (kern-being-get-current-faction kb2)))
1195 (define (make-enemies kb1 kb2)
1196 (harm-relations kb1 kb2)
1197 (harm-relations kb1 kb2)
1198 (harm-relations kb1 kb2)
1199 (harm-relations kb1 kb2)
1202 (define (make-allies kb1 kb2)
1203 (improve-relations kb1 kb2)
1204 (improve-relations kb1 kb2)
1205 (improve-relations kb1 kb2)
1206 (improve-relations kb1 kb2)
1209 (define (is-bad-terrain-at? loc)
1210 (is-bad-terrain? (kern-place-get-terrain loc)))
1212 ;; put-random-stuff -- randomly generate locations within the given rectangle
1213 ;; and, if pred? is satisfied, pass the loc to ctor.
1214 (define (put-random-stuff place rect pred? ctor n)
1216 (let ((loc (cons place (rect-random rect))))
1220 (put-random-stuff place rect pred? ctor (- n 1)))
1221 (put-random-stuff place rect pred? ctor n)))))
1223 (define (drop-random-corpses kplace n)
1224 (put-random-stuff kplace
1226 (kern-place-get-width kplace)
1227 (kern-place-get-height kplace))
1229 (eqv? (kern-place-get-terrain loc)
1232 (kern-obj-put-at (mk-corpse-with-loot)
1236 (define (webify kplace x y w h)
1237 (define (drop-web x loc)
1238 (let ((kter (kern-place-get-terrain loc)))
1239 (if (or (eqv? kter t_grass)
1240 (eqv? kter t_boulder))
1241 (kern-obj-put-at (kern-mk-obj F_web_perm 1)
1243 (foldr-rect kplace x y w h drop-web nil))
1245 ;; Fill the rectangle with objects of the given type. If pred? is not null use
1246 ;; it to filter out unsuitable locations.
1247 (define (rect-fill-with-npc kplace x y w h npct pred?)
1248 (define (drop-obj x loc)
1249 (if (or (null? pred?)
1251 (kern-obj-put-at (kern-mk-obj ktype 1)
1253 (foldr-rect kplace x y w h drop-obj #f))
1255 ;; on-entry-to-dungeon-room -- generic place on-enty procedure for dungeon
1256 ;; rooms. When the player enters (or re-enters) a dungeon this looks for a
1257 ;; monster manager object and triggers it.
1258 (define (on-entry-to-dungeon-room kplace kplayer)
1259 ;;(println "on-entry-to-dungeon-room")
1261 ;;(println " signal")
1262 (signal-kobj kmm 'on kmm nil))
1263 (kplace-get-objects-of-type kplace t_monman))
1266 ;; trigger anything with an 'on-entry' ifc
1267 (define (on-entry-trigger-all kplace kplayer)
1269 (signal-kobj kobj 'on-entry kobj))
1270 (kern-place-get-objects kplace))
1274 ;; mk-dungeon-room -- make a 19x19 dungeon room (simplified form of
1276 (define (mk-dungeon-room tag name terrain . objects)
1280 (kern-mk-map nil 19 19 pal_expanded terrain)
1283 #f ; large-scale (wilderness)
1284 #f ; tmp combat place
1288 ;; objects -- automatically add a monster manager
1289 (cons (put (mk-monman) 0 0)
1291 (list 'on-entry-to-dungeon-room) ; hooks
1292 nil ; edge entrances
1295 (define (mk-combat-map tag . terrain)
1296 (kern-mk-map tag 19 19 pal_expanded terrain))
1298 (define (mk-tower tag name terrain entrances . objects)
1302 (kern-mk-map nil 19 19 pal_expanded terrain)
1305 #f ; large-scale (wilderness)
1306 #f ; tmp combat place
1310 ;; objects -- automatically add a monster manager
1311 (cons (put (mk-monman) 0 0)
1313 (list 'on-entry-to-dungeon-room) ; hooks
1314 entrances ; edge entrances
1317 ;; Just like mk-tower but make the sprite configurable
1318 (define (mk-19x19-town tag name sprite terrain entrances . objects)
1322 (kern-mk-map nil 19 19 pal_expanded terrain)
1325 #f ; large-scale (wilderness)
1326 #f ; tmp combat place
1329 ;; objects -- automatically add a monster manager
1330 (cons (put (mk-monman) 0 0) objects)
1331 (list 'on-entry-to-dungeon-room 'on-entry-trigger-all) ; hooks
1332 entrances ; edge entrances
1336 ;; mk-dungeon-level -- given a 2d list of rooms, connect them up as neighbors
1337 (define (mk-dungeon-level . rooms)
1338 (define (bind-dir r1 r2 dir)
1339 (if (and (not (null? r1))
1341 (kern-place-set-neighbor dir r1 r2)))
1342 (define (bind-row top bot)
1343 (if (not (null? top))
1345 (if (not (null? (cdr top)))
1346 (bind-dir (car top) (cadr top) east))
1348 (bind-row (cdr top) nil)
1350 (bind-dir (car top) (car bot) south)
1351 (if (not (null? (cdr bot)))
1352 (bind-dir (car top) (cadr bot) southeast))
1353 (if (not (null? (cdr top)))
1354 (bind-dir (cadr top) (car bot) southwest))
1355 (bind-row (cdr top) (cdr bot)))))))
1356 (define (bind-rooms rooms)
1357 (if (not (null? rooms))
1359 (bind-row (car rooms)
1360 (if (null? (cdr rooms))
1363 (bind-rooms (cdr rooms)))))
1367 (define (println . args)
1372 (define (is-bad-field-at? kchar loc)
1373 (define (is-bad-field? val ktype)
1375 (and (is-field? ktype)
1376 (not (is-immune-to-field? kchar ktype)))))
1377 (foldr is-bad-field?
1379 (kern-get-objects-at loc)))
1381 (define (is-bad-loc? kchar loc)
1383 (is-bad-terrain-at? loc)
1384 (is-bad-field-at? kchar loc)
1387 (define (is-good-loc? kchar loc)
1388 ;;(println "is-good-loc?")
1389 (and (passable? loc kchar)
1390 (not (occupied? loc))
1391 (not (is-bad-loc? kchar loc))))
1393 (define (get-off-bad-tile? kchar)
1394 ;;(println "get-off-bad-tile")
1396 (define (choose-good-tile tiles)
1397 ;;(display "choose-good-tile")(newline)
1400 (if (is-good-loc? kchar (car tiles))
1402 (choose-good-tile (cdr tiles)))))
1404 (define (move-to-good-tile)
1405 ;;(display "move-to-good-tile")(newline)
1406 (let* ((curloc (kern-obj-get-location kchar))
1407 (tiles (get-4-neighboring-tiles curloc))
1408 (newloc (choose-good-tile tiles)))
1412 ;;(display "moving")(newline)
1413 (kern-obj-move kchar
1414 (- (loc-x newloc) (loc-x curloc))
1415 (- (loc-y newloc) (loc-y curloc)))
1419 (is-bad-loc? kchar (kern-obj-get-location kchar))
1420 (move-to-good-tile)))
1422 (define (move-away-from-foes? kchar)
1423 ;;(println "move-away-from-foes?")
1424 (evade kchar (all-visible-hostiles kchar)))
1426 ;; random-loc -- choose a random location
1427 (define (random-loc kplace x y w h)
1429 (+ x (modulo (random-next) w))
1430 (+ y (modulo (random-next) h))))
1432 ;; random-loc -- choose a random location anywhere in the given place
1433 (define (random-loc-in-place kplace)
1437 (kern-place-get-width kplace)
1438 (kern-place-get-height kplace)))
1440 ;; random-loc-place-iter -- try up to n times to find a random location which
1442 (define (random-loc-place-iter kplace pred? n)
1445 (let ((loc (random-loc-in-place kplace)))
1448 (random-loc-place-iter kplace pred? (- n 1))))))
1450 (define (is-floor? loc)
1451 (let ((kter (kern-place-get-terrain loc)))
1452 (or (eqv? kter t_flagstones)
1453 (eqv? kter t_cobblestone))))
1455 (define (loc-is-empty? loc)
1456 (null? (kern-get-objects-at loc)))
1458 (define (mean-player-party-level)
1459 (let ((members (kern-party-get-members (kern-get-player))))
1460 (if (= 0 (length members))
1462 (/ (foldr (lambda (sum kchar)
1463 ;;(println "level:" (kern-char-get-level kchar))
1464 (+ sum (kern-char-get-level kchar)))
1467 (length members)))))
1469 (define (calc-level)
1471 (+ (mean-player-party-level)
1472 (num-player-party-members)
1473 (kern-dice-roll "1d5-3"))))
1475 (define (get-mech-at loc)
1476 (let ((mechs (filter kern-obj-is-mech?
1477 (kern-get-objects-at loc))))
1482 (define (handle-mech-at loc kchar)
1483 (let ((kmech (get-mech-at loc)))
1486 (signal-kobj kmech 'handle kmech kchar))))
1488 (define (get-place kobj)
1489 (loc-place (kern-obj-get-location kobj)))
1491 ;; xp to reach the given level
1492 (define (power base exp)
1495 (* base (power base (- exp 1)))))
1497 (define (lvl-xp lvl)
1498 (power 2 (+ 5 lvl)))
1500 (define (random-faction)
1501 (modulo (random-next) faction-num))
1503 (define (get-target-loc caster range)
1504 (kern-ui-target (kern-obj-get-location caster)
1507 ;;----------------------------------------------------------------------------
1508 ;; code for opening a moongate, warping in a monster, and re-closing it
1509 (define (open-moongate loc)
1510 (let ((kgate (mk-moongate nil)))
1511 (kern-obj-relocate kgate loc nil)
1512 (moongate-animate kgate moongate-stages)
1514 (define (close-moongate kgate)
1515 (moongate-animate kgate (reverse moongate-stages))
1516 (moongate-destroy kgate))
1517 (define (warp-in kchar loc dir faction)
1518 (display "warp-in")(newline)
1519 (kern-char-set-schedule kchar nil)
1520 (kern-obj-inc-ref kchar)
1521 (kern-obj-remove kchar)
1522 (kern-obj-relocate kchar loc nil)
1523 (kern-obj-dec-ref kchar)
1526 (kern-obj-relocate kchar (loc-offset loc dir) nil)
1527 (kern-being-set-base-faction kchar faction)
1530 ;;-----------------------------------------------------------------------------
1531 ;; re-mk-composite-sprite -- combine all the sprites into one layered sprite,
1532 ;; cloning ALL BUT the first sprite. Useful for re-decorating base sprites that
1533 ;; have already been cloned.
1534 (define (re-mk-composite-sprite sprites)
1535 (foldr (lambda (s1 s2) (kern-sprite-append-decoration s1 s2))
1539 ;;-----------------------------------------------------------------------------
1540 ;; mk-composite-sprite -- combine all the sprites into one composite sprite,
1541 ;; cloning all the sprites in the list.
1542 (define (mk-composite-sprite sprites)
1543 (re-mk-composite-sprite (cons (kern-sprite-clone (car sprites)
1547 ; (foldr (lambda (s1 s2) (kern-sprite-append-decoration s1 s2))
1548 ; (kern-sprite-clone (car sprites) nil)
1551 (define (kchar-in-vehicle? kchar)
1552 (let ((kparty (kern-char-get-party kchar)))
1555 (not (null? (kern-party-get-vehicle kparty))))))
1557 ;; is-in-darkness? -- #t iff light on this object's tile is less than the
1558 ;; threshold for "dark"
1559 (define (is-in-darkness? kobj)
1560 (< (kern-place-get-light (kern-obj-get-location kobj))
1563 ;; Convenience wrapper for kern-obj-add-to-inventory
1564 (define (give kpc ktype quantity)
1565 (kern-obj-add-to-inventory kpc ktype quantity))
1567 ;; Convenience wrapper for kern-obj-remove-from-inventory
1568 (define (take kobj ktype quantity)
1569 (kern-obj-remove-from-inventory kobj ktype quantity))
1571 ;; Return #t iff object has at least that many in inventory
1572 (define (has? kobj ktype quantity)
1573 (>= (num-in-inventory kobj ktype) quantity))
1575 ;; Safely if a character is in the player party. char-tag should be the
1576 ;; character's quoted scheme variable name, for example 'ch_dude.
1577 (define (in-player-party? kchar-tag)
1578 (println "in-player-party? " kchar-tag)
1579 (and (defined? kchar-tag)
1580 (let ((kchar (eval kchar-tag)))
1581 (and (is-alive? kchar)
1582 (is-player-party-member? kchar)))))
1584 (define (set-wind-north)
1585 (println "set-wind-north")
1586 (kern-set-wind north 10))
1588 ;; block-teleporting takes a place and a list of strings that looks
1589 ;; suspiciously like a terrain map, and uses the map to apply blocking
1590 ;; mechanisms to the place. Every "x#" entry in the map will cause a blocking
1591 ;; mechanism to be placed on that location. All other entries are ignored. The
1592 ;; blocking mechanisms prevent spells like blink from letting the player break
1593 ;; the fiction of a simulated multi-story place.
1594 (define (block-teleporting kplace map)
1595 (define (doline y lines)
1596 (define (docol x tokens)
1597 (cond ((null? tokens) nil)
1599 (if (and (char=? #\x (car tokens))
1600 (char=? #\# (cadr tokens)))
1602 (kern-obj-put-at (mk-blocker) (list kplace x y))
1604 (docol (+ x 1) (cdddr tokens)))))
1605 (cond ((null? lines) nil)
1607 (docol 0 (string->list (car lines)))
1608 (doline (+ y 1) (cdr lines)))))
1611 ;; Find the visible object of the given type nearest to the kchar.
1612 (define (find-nearest kchar ktype)
1613 (let ((objects (filter (lambda (kobj)
1614 (and (kobj-is-type? kobj ktype)
1615 (can-see? kchar kobj)))
1616 (kern-place-get-objects (loc-place (kern-obj-get-location kchar))))))
1617 (cond ((null? objects) nil)
1619 (nearest-obj kchar objects)))))
1621 ;; Return an integer describing the sign of x
1627 ;; Return a list of (x . y) pairs that constitute a line between two
1628 ;; points. Uses Bresenhaum's line-drawing algorithm.
1629 (define (line x1 y1 x2 y2)
1630 (let* ((dx (- x2 x1))
1641 ;;(println "f1 i=" i " px=" px " py=" py)
1648 (set! py (+ py sdy))))
1649 (set! px (+ px sdx))
1653 ;;(println "f2 i=" i " px=" px " py=" py)
1660 (set! px (+ px sdx))))
1661 (set! py (+ py sdy))
1665 (cons (cons x1 y1) (f1 0)))
1667 (cons (cons x1 y1) (f2 0))))))
1669 ;; Utility for generating dice from numbers easily
1671 (define (mkdice dice size)
1672 (let ((numstr (if (number? dice)
1673 (number->string dice)
1675 (sizestr (if (number? size)
1676 (number->string size)
1678 (string-append numstr "d" sizestr)))
1680 ;; output for effects that should only be noted if visible
1682 (define (msg-log-visible loc . args)
1683 (if (kern-place-is-visible? loc)
1684 (apply kern-log-msg args)
1688 ;; Print dots across the console (similar to the u4 shrine meditation)
1689 (define (log-dots n delay)
1692 (kern-log-continue ".")
1701 (define (find-first fn? lst)
1706 (find-first fn? (cdr lst)))))
1708 (define (append! lst val)
1709 (cond ((null? lst) nil)
1710 ((null? (cdr lst)) (set-cdr! lst val))
1711 (else (append! (cdr lst) val))))
1713 (define (repeat fn n)
1717 (repeat fn (- n 1)))))
1719 (define (string-lower str)
1720 (list->string (map char-downcase (string->list str))))
1725 (define (rect-x r) (car r))
1726 (define (rect-y r) (cadr r))
1727 (define (rect-w r) (caddr r))
1728 (define (rect-h r) (cadddr r))
1730 (define (rect-down r v)
1731 (list (rect-x r) (+ v (rect-y r)) (rect-w r) (rect-h r)))
1733 (define (rect-crop-down r v)
1734 (list (rect-x r) (+ v (rect-y r)) (rect-w r) (- (rect-h r) v)))
1736 (define (rect-offset r x y)
1737 (list (+ x (rect-x r)) (+ y (rect-y r)) (rect-w r) (rect-h r)))
1739 (define (rect-crop-offset r x y)
1740 (list (+ x (rect-x r)) (+ y (rect-y r)) (- (rect-w r) x) (- (rect-h r) y)))
1742 (define (1- x) (- x 1))
1743 (define (1+ x) (+ x 1))
1745 ;; Standard dc vs 1d20 + bonus, with a perfect roll granting automatic success.
1746 (define (check-roll dc bonus)
1747 (let ((roll (kern-dice-roll "1d20")))
1749 (> (+ roll bonus) dc))))