worlds/haxima-1.002/naz.scm

   1
   2 ;; init.scm -- contains lots of common scheme utilities
   3 (load "init.scm")
   4
   5 ;; Result codes (these belong here because they are tied to kernel values, see
   6 ;; result.h)
   7 (define result-ok          0)
   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)
  16
  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)))
  21
  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)
  25   (kern-interp-error x)
  26   (apply throw x))
  27 (define *error-hook* my-error-hook)
  28
  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)
  32   (kern-include fname)
  33   (load fname))
  34
  35 (define nil '())
  36
  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) '())
  41         ((symbol? expr)
  42          (if (defined? expr)
  43              (eval expr)
  44              '()))
  45         (eval expr)))
  46
  47 ;; filter -- filter-in elements from a list
  48 (define (filter pred seq)
  49   (cond ((null? seq) nil)
  50         ((pred (car seq))
  51          (cons (car seq)
  52                (filter pred (cdr seq))))
  53         (else (filter pred (cdr seq)))))
  54
  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)))
  61           (if (here? loc) loc
  62               (do-search (append (cdr queue)
  63                                  (filter (lambda (v) (not (member v visited)))
  64                                          (next loc)))
  65                          (append (list loc) visited)
  66                          (- depth 1))))))
  67   (do-search (list start) nil maxdepth))
  68
  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)
  73     (if (null? queue) nil
  74         (let ((loc (car queue)))
  75           (proc loc)
  76           (do-search (append (cdr queue)
  77                              (filter (lambda (v) (not (member v visited)))
  78                                      (next loc)))
  79                      (append (list loc) visited)))))
  80   (do-search (list start) nil))
  81
  82 ;; Set element k of list x to val (zero-indexed)
  83 (define (list-set-ref! x k val)
  84   (if (zero? k)
  85       (set-car! x val)
  86       (list-set-ref! (cdr x) (- k 1) val)))
  87
  88 ;; Check if a list contains an element.
  89 (define (in-list? elem lst)
  90   (foldr (lambda (a b) (or a (eqv? b elem)))
  91          #f
  92          lst))
  93
  94 (define (in-text-list? elem lst)
  95   (foldr (lambda (a b) (or a (equal? b elem)))
  96          #f
  97          lst))
  98
  99 ;; Check if a location is passable to a character
 100 (define (passable? loc kobj)
 101   (kern-place-is-passable loc kobj))
 102
 103 (define (obj-is-char? kobj) (kern-obj-is-being? kobj))
 104 (define (is-being? kobj) (kern-obj-is-being? kobj))
 105
 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)))
 109          #f
 110          (kern-get-objects-at loc)))
 111
 112 (define (get-beings-at loc)
 113   (filter kern-obj-is-being?
 114           (kern-get-objects-at loc)))
 115
 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)
 120                                                                         (passable? loc char)
 121                                                                         (not (occupied? loc))))
 122           neighbors
 123           origin
 124           10))
 125
 126 ;; Generic proc to summon other beings. Used by spells and some special
 127 ;; effects.
 128 (define (summon origin mk-critter faction count)
 129   (define (run-loop n)
 130     (if (= n 0) nil
 131         (let* ((critter (kern-obj-set-temporary (kern-being-set-base-faction
 132                                                  (mk-critter)
 133                                                  faction)
 134                                                 #t))
 135                (loc (pick-loc origin critter)))
 136           (cond ((null? loc) nil)
 137                 (else
 138                  (kern-obj-put-at critter loc)
 139                  (run-loop (- n 1)))))))
 140   (run-loop count))
 141
 142 ;; Like summon but the beings are permanent, not temporary.
 143 (define (psummon origin mk-critter count)
 144   ;;;(display "psummon")(newline)
 145   (define (run-loop n)
 146     (if (= n 0) nil
 147         (let* ((critter (kern-obj-inc-ref (mk-critter)))
 148                (loc (pick-loc origin critter)))
 149           (cond ((null? loc) (kern-obj-dec-ref critter))
 150                (else
 151                 (kern-obj-put-at critter loc)
 152                 (kern-obj-dec-ref critter)
 153                 (run-loop (- n 1)))))))
 154   (run-loop count))
 155
 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))))
 164
 165 ;; check if klooker can can see anything in the list kobs
 166 (define (can-see-any? klooker kobjs)
 167   (if (null? kobjs)
 168       #f
 169       (or (can-see? klooker (car kobjs))
 170           (can-see-any? klooker (cdr kobjs)))))
 171
 172 ;; check if knpc can see any of the player party members
 173 (define (any-player-party-member-visible? knpc)
 174   (can-see-any? knpc
 175                 (kern-party-get-members (kern-get-player))))
 176
 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))))))
 180     (if (null? loc)
 181         nil
 182         (loc-place loc))))
 183
 184 (define (num-player-party-members)
 185   ;;(display "num-player-party-members")(newline)
 186   (length (kern-party-get-members (kern-get-player))))
 187
 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))
 193                      (or found
 194                          (and (not (eqv? kchar kchar2))
 195                               (is-alive? kchar2))))
 196                    #f
 197                    (kern-party-get-members (kern-get-player))))
 198        ))
 199
 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)))
 204
 205 ;; Check if an object is allied with a character
 206 (define (is-ally? kbeing kobj)
 207   (kern-being-is-ally? kbeing kobj))
 208
 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)))))
 213
 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)))))
 218
 219
 220 ;; Count the number of hostiles
 221 (define (num-hostiles kchar)
 222   (length (all-hostiles kchar)))
 223
 224 ;; Count the number of friendlies
 225 (define (num-allies kchar)
 226   (length (all-allies kchar)))
 227
 228 ;; Find all beings hostile
 229 (define (all-visible-hostiles kbeing)
 230   (kern-being-get-visible-hostiles kbeing))
 231
 232 (define (any-visible-hostiles? kchar)
 233   (> (length (all-visible-hostiles kchar)) 0))
 234
 235 (define (nearest-visible-hostile kchar)
 236   (nearest-obj kchar (all-visible-hostiles kchar)))
 237
 238 ;; Find all allies
 239 (define (all-visible-allies kbeing)
 240   (kern-being-get-visible-allies kbeing))
 241
 242 ;; Count the number of visible friendlies
 243 (define (num-visible-allies kchar)
 244   (length (all-visible-allies kchar)))
 245
 246 ;; Count the number of hostiles
 247 (define (num-visible-hostiles kchar)
 248   (length (all-visible-hostiles kchar)))
 249
 250
 251 ;; Find all the characters in a place
 252 (define (all-chars kplace)
 253   (kern-place-get-beings kplace))
 254
 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))
 259       radius))
 260
 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)
 265              range
 266              ktarg))
 267
 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))
 273                 radius))
 274           objlst))
 275
 276 ;; Return a list of all hostiles in range of the given location
 277 (define (get-hostiles-in-range-of-loc kchar range loc)
 278   (all-in-range loc
 279                 range
 280                 (kern-being-get-visible-hostiles kchar)))
 281
 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
 285                                 range
 286                                 (kern-obj-get-location kchar)))
 287
 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)))
 291   (all-in-range loc
 292                 range
 293                 (kern-place-get-beings (loc-place loc)))))
 294
 295 ;; Convenience proc for rolling dtables by hand
 296 (define (dtable-row . cols) cols)
 297
 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)))
 302
 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))))
 308
 309 ;; Inefficient code to find nearest location from a list
 310 (define (nearest-loc kobj klist)
 311   (println "nearest-loc: " klist)
 312   (if (null? klist)
 313       nil
 314       (let ((kloc (kern-obj-get-location kobj)))
 315         (foldr (lambda (a b)
 316                  (if (< (loc-city-block-distance kloc a)
 317                         (loc-city-block-distance kloc b))
 318                      a
 319                      b))
 320                (car klist)
 321                (cdr klist)))))
 322
 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)))))
 339
 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)))
 346
 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)))))
 352
 353 (define (notnull? val) (not (null? val)))
 354
 355 (define (being-at? loc)
 356   (not (null? (filter kern-obj-is-being? (kern-get-objects-at loc)))))
 357
 358 (define (get-being-at loc)
 359   (let ((beings (filter kern-obj-is-being? (kern-get-objects-at loc))))
 360     (if (null? beings)
 361         nil
 362         (car beings))))
 363
 364 (define (is-dead? kchar)
 365   (kern-char-is-dead? kchar))
 366
 367 (define (is-alive? kchar)
 368   (not (is-dead? kchar)))
 369
 370 (define (has-ap? kobj)
 371   (> (kern-obj-get-ap kobj) 0))
 372
 373 (define (has-ap-debt? kobj)
 374   (< (kern-obj-get-ap kobj) 0))
 375
 376 (define (has-skill? kchar kskill)
 377   (in-list? kskill
 378             (kern-char-get-skills kchar)))
 379
 380 (define (flee kchar)
 381   ;;;(display "flee")(newline)
 382   (kern-char-set-fleeing kchar #t))
 383
 384 (define (wander kchar)
 385   (kern-obj-wander kchar))
 386
 387 (define (weakest kchar-a kchar-b)
 388   (if (< (kern-char-get-hp kchar-a)
 389          (kern-char-get-hp kchar-b))
 390       a
 391       b))
 392
 393 (define (join-player kchar)
 394   (kern-char-join-player kchar))
 395
 396 (define (random-select list)
 397   (if (or (null? list)
 398           (= 0 (length list)))
 399       nil
 400       (list-ref list (modulo (random-next) (length list)))))
 401
 402 (define (taunt kchar ktarg taunts)
 403   (say kchar (random-select taunts)))
 404
 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))))
 411
 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
 415 ;; filter.
 416 ;; ----------------------------------------------------------------------------
 417 (define (foldr-rect kplace x y w h proc ival)
 418   (foldr proc ival (loc-enum-rect kplace x y w h)))
 419
 420 ;;----------------------------------------------------------------------------
 421 ;; Return a list of locations with matching terrain
 422 ;;----------------------------------------------------------------------------
 423 (define (find-terrain kplace x y w h kter)
 424   (define (check loc)
 425     (if (eqv? (kern-place-get-terrain loc) kter)
 426         loc
 427         nil))
 428   (search-rect kplace x y w h check))
 429
 430 (define (on-terrain? kobj kter)
 431   (eqv? kter (kern-place-get-terrain (kern-obj-get-location kobj))))
 432
 433 (define (all-visible-terrain-of-type kobj kter)
 434   (filter (lambda (x)
 435             (eqv? kter
 436                   (kern-place-get-terrain x)))
 437           (kern-being-get-visible-tiles kobj)))
 438
 439 (define (find-nearest-visible-terrain-of-type kobj kter)
 440   (nearest-loc kobj (all-visible-terrain-of-type kobj kter)))
 441
 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)
 448                 3 3
 449                (lambda (val neighbor)
 450                  ;;(println neighbor " neighbor? " (equal? neighbor loc) " blocks? " (kern-place-blocks-los? neighbor))
 451                  (and val
 452                       (or (eq? neighbor loc)
 453                           (kern-place-blocks-los? neighbor))))
 454                 #t
 455                 )))
 456
 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)
 460         ktype))
 461
 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)))
 467
 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)
 472   (define (check loc)
 473     (define (scanobjlst lst)
 474       (foldr (lambda (a b)
 475                (or a (kobj-is-type? b ktype)))
 476              #f
 477              lst))
 478     (if (scanobjlst (kern-get-objects-at loc))
 479         loc
 480         nil))
 481   (search-rect kplace x y w h check))
 482
 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)
 488           (else
 489            ;;(println " " (kern-type-get-name (car (car inv))))
 490            (hasit? item (cdr inv)))))
 491   (hasit? ktype (kern-char-get-inventory kchar)))
 492
 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)))
 500
 501 (define (any-in-inventory? kchar lst)
 502   (foldr (lambda (v k)
 503            (or v
 504                (in-inventory? kchar k)))
 505          #f
 506          lst))
 507
 508 (define (all-in-inventory? kchar lst)
 509   (foldr (lambda (v k)
 510            (and v
 511                (in-inventory? kchar k)))
 512          #t
 513          lst))
 514
 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)
 522                 " uses 1 "
 523                 (kern-type-get-name ktype))
 524   #t)
 525
 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))
 533
 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
 537 ;; distance..
 538 ;;----------------------------------------------------------------------------
 539 (define (mdist a b R) (min (msub a b R) (msub b a R)))
 540
 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 ;; ----------------------------------------------------------------------------
 545 (gc-verbose #t)
 546
 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")
 551     (newline)
 552     result))
 553
 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)))
 561
 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)))
 567          #f
 568          (kern-get-objects-at loc)))
 569
 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)))
 576          #f
 577          ktypes))
 578
 579 ;; is-player-party-member? -- #t iff kchar is in player party
 580 (define (is-player-party-member? kchar)
 581   (in-list? kchar
 582             (kern-party-get-members (kern-get-player))))
 583
 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)
 589       (begin
 590         (if (not (is-player-party-member? kchar))
 591             (kern-log-msg (kern-obj-get-name kchar)
 592                           " gets "
 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))))
 599
 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)))
 605     (if (notnull? objs)
 606         (kobj-get (car objs) kchar))))
 607
 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))
 616     ((4) (mk-loc kplace
 617                  (- (kern-place-get-height kplace) 1)
 618                  (- (kern-place-get-width kplace) 1)))))
 619
 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)))
 628       (proc kchar coords)
 629       (pathfind kchar coords)))
 630
 631 ;; ----------------------------------------------------------------------------
 632 ;; evade -- simple alg for evading melee foes
 633 ;;
 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.
 640 ;;
 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
 643 ;; vector(s).
 644 ;;
 645 ;; Now allowing diagonals, since that factor has changed
 646 ;;
 647 ;; TODO: probably shouldnt flee over dangerous terrains
 648 ;;
 649 ;; ----------------------------------------------------------------------------
 650 (define (evade kchar foes)
 651   (let* ((tloc (kern-obj-get-location kchar))
 652          (v (loc-canonical
 653                                 (foldr
 654                                         (lambda (accum thisfoe)
 655                                                 (loc-sum accum
 656                                                         (loc-diff (kern-obj-get-location thisfoe) tloc)
 657                                                 ))
 658                                         (mk-loc (loc-place tloc) 0 0)
 659                                         foes)
 660                                 ))
 661                         )
 662                 (define (move dx dy)
 663                         (if (kern-place-is-passable
 664                                         (loc-sum
 665                                                 (mk-loc (loc-place tloc) dx dy)
 666                                                 tloc)
 667                                         kchar)
 668                                 (kern-obj-move kchar dx dy)
 669                                 #f))
 670                 (define (evade-on-normal)
 671                                 (move (loc-x v) (loc-y v)))
 672
 673                 (or (evade-on-normal)
 674                         (and (not (eq? 0 (loc-y v)))
 675                                 (move (loc-x v) 0))
 676                         (and (not (eq? 0 (loc-x v)))
 677                                 (move 0 (loc-y v))))
 678                 ))
 679
 680
 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)
 686   (if (null? lst) nil
 687       (foldr (lambda (a b)
 688                (if (loc-closer? (kern-obj-get-location a)
 689                                 (kern-obj-get-location b)
 690                                 origin)
 691                    a
 692                    b))
 693                (car lst)
 694                (cdr lst))))
 695
 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))
 703          kmap
 704          blits))
 705
 706 (define (fill-terrain-prob kter kplace ox oy ow oh prob)
 707   (define (fill x y w h)
 708     (if (> h 0)
 709         (if (> w 0)
 710             (begin
 711               (if (<= (modulo (random-next)
 712                               100)
 713                       prob)
 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)))))
 717   (fill ox oy ow oh))
 718
 719 (define (fill-terrain kter kplace ox oy ow oh)
 720   (fill-terrain-prob kter kplace ox oy ow oh 100))
 721
 722 ;;============================================================================
 723 ;; rect
 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))
 734        (< x (rect-ex r))))
 735 (define (y-in-rect? y r)
 736   (and (>= y (rect-y r))
 737        (< y (rect-ey r))))
 738 (define (xy-in-rect? x y r)
 739   (and (x-in-rect? x r)
 740        (y-in-rect? y 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)
 746                (loc-y loc)
 747                rect))
 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)))))
 751
 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))
 758
 759 (define (put obj x y) (list obj x y))
 760
 761 ;; lookup-spell-by-handler -- find a spell in the list of all spells
 762 (define (lookup-spell handler)
 763   (define (search-spells slist)
 764     (if (null? slist)
 765         nil
 766         (let ((spell (car slist)))
 767           (if (eqv? (spell-handler spell)
 768                     handler)
 769               spell
 770               (search-spells (cdr slist))))))
 771   (search-spells spells))
 772
 773 ;; generic lookup
 774 (define (lookup this? slist)
 775   (if (null? slist)
 776       nil
 777       (if (this? (car slist))
 778           (car slist)
 779           (lookup this? (cdr slist)))))
 780
 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)))
 784     (if (null? spell)
 785         #f
 786         (and (>= (kern-char-get-mana kchar)
 787                  (spell-cost spell))
 788              (>= (kern-char-get-level kchar)
 789                  (spell-level spell))))))
 790
 791 ;; cast0 - cast a spell which requires no args if possible, assumes kchar has
 792 ;; enough mana
 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)
 798                 " casts "
 799                 (spell-name spell)))
 800
 801 ;; cast1 - cast a spell which requires one arg if possible, assumes kchar has
 802 ;; enough mana
 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)
 809                 " casts "
 810                 (spell-name spell)
 811                 " on "
 812                 (kern-obj-get-name ktarg)
 813                 "!"))
 814
 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)
 823     (if (null? kter)
 824         #f
 825         (let ((pclass (kern-terrain-get-pclass kter)))
 826           (foldr (lambda (a b) (or a (= pclass b)))
 827                  #f
 828                  (list pclass-grass pclass-trees pclass-forest))))))
 829
 830 (define (get-8-neighboring-tiles loc)
 831   (let ((kplace (loc-place loc))
 832         (x (loc-x loc))
 833         (y (loc-y loc)))
 834     (filter kern-is-valid-location?
 835             (map (lambda (offset) (mk-loc kplace
 836                                           (+ (car offset) x)
 837                                           (+ (cdr offset) y)))
 838                  (list (cons -1 -1)
 839                        (cons  0 -1)
 840                        (cons  1 -1)
 841                        (cons -1  0)
 842                        (cons  1  0)
 843                        (cons -1  1)
 844                        (cons  0  1)
 845                        (cons  1  1))))))
 846
 847 (define (get-4-neighboring-tiles loc)
 848   (let ((kplace (loc-place loc))
 849         (x (loc-x loc))
 850         (y (loc-y loc)))
 851     (filter kern-is-valid-location?
 852             (map (lambda (offset) (mk-loc kplace
 853                                           (+ (car offset) x)
 854                                           (+ (cdr offset) y)))
 855                  (list (cons  0 -1)
 856                        (cons -1  0)
 857                        (cons  1  0)
 858                        (cons  0  1)
 859                        )))))
 860
 861 (define (shake-map dur)
 862   (if (> dur 0)
 863       (begin
 864         (kern-map-set-jitter #t)
 865         (kern-map-repaint)
 866         (shake-map (- dur 1)))
 867       (begin
 868         (kern-map-set-jitter #f)
 869         (kern-map-repaint))))
 870
 871 (define (random-vdir)
 872   (random-select (list (cons -1 0)
 873                        (cons 1 0)
 874                        (cons 0 -1)
 875                        (cons 0 1))))
 876
 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)))))
 881
 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)))
 887         (begin
 888           (kern-obj-relocate kobj loc nil)
 889           #t)
 890         #f)))
 891
 892 (define (stagger kchar)
 893   (let ((vdir (random-vdir)))
 894     (push kchar (car vdir) (cdr vdir) 1)))
 895
 896 (define (end-turn kobj)(kern-obj-set-ap kobj 0))
 897
 898 (define (add-effect-multiple kobj keff fgob q)
 899   (if (> q 0)
 900       (begin
 901         (kern-obj-add-effect kobj keff fgob)
 902         (add-effect-multiple kobj keff fgob (- q 1)))))
 903
 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))
 913
 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)))
 918
 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)))
 923
 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)))
 928
 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))
 932
 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))
 936
 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))
 940
 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))
 944
 945 (define (set-max-hp kchar)
 946   (kern-char-set-hp kchar
 947                     (kern-char-get-max-hp kchar)))
 948
 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))
 953      mod
 954      (* lvl
 955         (+ (kern-species-get-hp-mult sp)
 956            (if (null? occ) 0 (kern-occ-get-hp-mult occ))
 957            mult))))
 958
 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))
 963      mod
 964      (* lvl
 965         (+ (kern-species-get-mp-mult sp)
 966            (if (null? occ) 0 (kern-occ-get-mp-mult occ))
 967            mult))))
 968
 969
 970 ;; set-level -- set character to level and max out hp and mana (intended for
 971 ;; new npc creation)
 972 (define (set-level kchar lvl)
 973   (kern-char-set-level kchar lvl))
 974
 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))))
 983
 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)))
 989
 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)))
 995
 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)))
1000
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)
1005         #f
1006         (evade kchar nearby-foes))))
1007
1008 (define (dump-char kchar)
1009   (if (null? kchar)
1010       (println "nil")
1011       (begin
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)) "]"
1018                  ))))
1019
1020
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)))))
1031                  ktarg
1032                  kpatient))
1033            nil
1034            (all-visible-allies kchar))))
1035
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)))
1041     (if (null? patient)
1042         #f
1043         (begin
1044           ;;(display "selected ")(dump-char patient)
1045           (if (in-range? (kern-obj-get-location kchar)
1046                          2
1047                          patient)
1048               #f
1049               (pathfind kchar (kern-obj-get-location patient)))))))
1050
1051 (define (prompt-for-key)
1052   (kern-log-msg "<Hit any key to continue>")
1053   (kern-ui-waitkey))
1054
1055 (define (ship-at? loc) (not (null? (kern-place-get-vehicle loc))))
1056
1057 (define (take-player-gold q)
1058   (kern-player-set-gold (- (kern-player-get-gold) q)))
1059
1060 (define (give-player-gold q)
1061   (kern-player-set-gold (+ (kern-player-get-gold) q)))
1062
1063 (define (player-has-gold? q)
1064   (>= (kern-player-get-gold) q))
1065
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))
1071
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))))
1077     (if (> hp 0)
1078         (begin
1079           (say knpc "VAS MANI! Be healed, "
1080                (kern-obj-get-name kchar))
1081           (kern-map-flash hp)
1082           (kern-obj-heal kchar hp)
1083           #t)
1084         (begin
1085           (say knpc (kern-obj-get-name kchar)
1086                " is not wounded!")
1087           (prompt-for-key)
1088           #f))))
1089
1090 (define (cure-service kchar knpc)
1091   ;;(display "cure-service")(newline)
1092   (if (is-poisoned? kchar)
1093       (begin
1094         (say knpc "AN NOX! You are cured, "
1095              (kern-obj-get-name kchar))
1096         (kern-map-flash 1)
1097         (kern-obj-remove-effect kchar ef_poison))
1098       (begin
1099         (say knpc (kern-obj-get-name kchar)
1100              " is not poisoned!")
1101         (prompt-for-key)
1102         #f)))
1103
1104 (define (resurrect-service kchar knpc)
1105   ;;(display "resurrect-service")(newline)
1106   (if (is-dead? kchar)
1107       (begin
1108        (say knpc "IN MANI CORP! Arise, "
1109             (kern-obj-get-name kchar))
1110        (kern-map-flash 500)
1111        (resurrect kchar)
1112        (kern-obj-heal kchar 10))
1113       (begin
1114         (say knpc (kern-obj-get-name kchar)
1115              " is not dead!")
1116         (prompt-for-key)
1117         #f)))
1118
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)
1122
1123   (define (list-services)
1124     (map (lambda (svc)
1125            (string-append (svc-name svc)
1126                           "..."
1127                           (number->string (svc-price svc))
1128                           " gold"))
1129          services))
1130
1131   ;; line-name - convert a string like "Heal...30 gold" to "Heal"
1132   (define (line-name line)
1133     (define (extract l)
1134       (if (null? l)
1135           nil
1136           (if (char=? (car l) #\.)
1137               nil
1138               (cons (car l) (extract (cdr l))))))
1139     (if (null? line)
1140         nil
1141         (list->string (extract (string->list line)))))
1142
1143   (define (lookup-svc line)
1144     (let ((name (line-name line)))
1145       (if (null? name)
1146           nil
1147           (lookup (lambda (svc)
1148                     (string=? name
1149                               (svc-name svc)))
1150                   services))))
1151
1152   (define (choose-svc)
1153     (lookup-svc (apply kern-ui-select-from-list (list-services))))
1154
1155   (let ((svc (choose-svc)))
1156
1157     (define (can-pay?)
1158       (if (player-has-gold? (svc-price svc))
1159           #t
1160           (begin
1161             (say knpc "You don't have enough gold!")
1162             #f)))
1163
1164     (define (apply-svc)
1165       (let ((kchar (kern-ui-select-party-member)))
1166         (if (null? kchar)
1167             #f
1168             (if (apply (svc-proc svc) (list kchar knpc))
1169                 (begin
1170                   (take-player-gold (svc-price svc))
1171                   #t)))))
1172
1173     (and (not (null? svc))
1174          (can-pay?)
1175          (apply-svc))))
1176
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)
1180     (if (null? members)
1181         #f
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)))))
1186
1187 (define (improve-relations kb1 kb2)
1188   (kern-dtable-inc (kern-being-get-current-faction kb1)
1189                    (kern-being-get-current-faction kb2)))
1190
1191 (define (harm-relations kb1 kb2)
1192   (kern-dtable-dec (kern-being-get-current-faction kb1)
1193                    (kern-being-get-current-faction kb2)))
1194
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)
1200   )
1201
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)
1207   )
1208
1209 (define (is-bad-terrain-at? loc)
1210   (is-bad-terrain? (kern-place-get-terrain loc)))
1211
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)
1215   (if (> n 0)
1216       (let ((loc (cons place (rect-random rect))))
1217         (if (pred? loc)
1218             (begin
1219               (ctor loc)
1220               (put-random-stuff place rect pred? ctor (- n 1)))
1221             (put-random-stuff place rect pred? ctor n)))))
1222
1223 (define (drop-random-corpses kplace n)
1224   (put-random-stuff kplace
1225                     (mk-rect 0 0
1226                              (kern-place-get-width kplace)
1227                              (kern-place-get-height kplace))
1228                     (lambda (loc)
1229                       (eqv? (kern-place-get-terrain loc)
1230                             t_grass))
1231                     (lambda (loc)
1232                       (kern-obj-put-at (mk-corpse-with-loot)
1233                                        loc))
1234                     n))
1235
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)
1242                            loc))))
1243   (foldr-rect kplace x y w h drop-web nil))
1244
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?)
1250             (pred? loc))
1251         (kern-obj-put-at (kern-mk-obj ktype 1)
1252                          loc)))
1253 (foldr-rect kplace x y w h drop-obj #f))
1254
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")
1260   (map (lambda (kmm)
1261          ;;(println " signal")
1262          (signal-kobj kmm 'on kmm nil))
1263        (kplace-get-objects-of-type kplace t_monman))
1264   )
1265
1266 ;; trigger anything with an 'on-entry' ifc
1267 (define (on-entry-trigger-all kplace kplayer)
1268   (map (lambda (kobj)
1269          (signal-kobj kobj 'on-entry kobj))
1270        (kern-place-get-objects kplace))
1271   )
1272
1273
1274 ;; mk-dungeon-room -- make a 19x19 dungeon room (simplified form of
1275 ;; kern-mk-place)
1276 (define (mk-dungeon-room tag name terrain . objects)
1277   (kern-mk-place tag
1278                  name
1279                  nil     ; sprite
1280                  (kern-mk-map nil 19 19 pal_expanded terrain)
1281                  #f      ; wraps
1282                  #t      ; underground
1283                  #f      ; large-scale (wilderness)
1284                  #f      ; tmp combat place
1285                  nil     ; subplaces
1286                  nil     ; neighbors
1287
1288                  ;; objects -- automatically add a monster manager
1289                  (cons (put (mk-monman) 0 0)
1290                        objects)
1291                  (list 'on-entry-to-dungeon-room) ; hooks
1292                  nil     ; edge entrances
1293                  ))
1294
1295 (define (mk-combat-map tag . terrain)
1296   (kern-mk-map tag 19 19 pal_expanded terrain))
1297
1298 (define (mk-tower tag name terrain entrances . objects)
1299   (kern-mk-place tag
1300                  name
1301                  s_keep     ; sprite
1302                  (kern-mk-map nil 19 19 pal_expanded terrain)
1303                  #f      ; wraps
1304                  #f      ; underground
1305                  #f      ; large-scale (wilderness)
1306                  #f      ; tmp combat place
1307                  nil     ; subplaces
1308                  nil     ; neighbors
1309
1310                  ;; objects -- automatically add a monster manager
1311                  (cons (put (mk-monman) 0 0)
1312                        objects)
1313                  (list 'on-entry-to-dungeon-room) ; hooks
1314                  entrances     ; edge entrances
1315                  ))
1316
1317 ;; Just like mk-tower but make the sprite configurable
1318 (define (mk-19x19-town tag name sprite terrain entrances . objects)
1319   (kern-mk-place tag
1320                  name
1321                  sprite
1322                  (kern-mk-map nil 19 19 pal_expanded terrain)
1323                  #f      ; wraps
1324                  #f      ; underground
1325                  #f      ; large-scale (wilderness)
1326                  #f      ; tmp combat place
1327                  nil     ; subplaces
1328                  nil     ; neighbors
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
1333                  ))
1334
1335
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))
1340              (not (null? r2)))
1341         (kern-place-set-neighbor dir r1 r2)))
1342   (define (bind-row top bot)
1343     (if (not (null? top))
1344         (begin
1345           (if (not (null? (cdr top)))
1346               (bind-dir (car top) (cadr top) east))
1347           (if (null? bot)
1348               (bind-row (cdr top) nil)
1349               (begin
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))
1358         (begin
1359           (bind-row (car rooms)
1360                     (if (null? (cdr rooms))
1361                         nil
1362                         (cadr rooms)))
1363           (bind-rooms (cdr rooms)))))
1364   (bind-rooms rooms))
1365
1366
1367 (define (println . args)
1368   (map display args)
1369   (newline))
1370
1371
1372 (define (is-bad-field-at? kchar loc)
1373   (define (is-bad-field? val ktype)
1374     (or val
1375         (and (is-field? ktype)
1376              (not (is-immune-to-field? kchar ktype)))))
1377   (foldr is-bad-field?
1378          #f
1379          (kern-get-objects-at loc)))
1380
1381 (define (is-bad-loc? kchar loc)
1382   (or
1383    (is-bad-terrain-at? loc)
1384    (is-bad-field-at? kchar loc)
1385    ))
1386
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))))
1392
1393 (define (get-off-bad-tile? kchar)
1394   ;;(println "get-off-bad-tile")
1395
1396   (define (choose-good-tile tiles)
1397     ;;(display "choose-good-tile")(newline)
1398     (if (null? tiles)
1399         nil
1400         (if (is-good-loc? kchar (car tiles))
1401             (car tiles)
1402             (choose-good-tile (cdr tiles)))))
1403
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)))
1409       (if (null? newloc)
1410           #f
1411           (begin
1412             ;;(display "moving")(newline)
1413             (kern-obj-move kchar
1414                            (- (loc-x newloc) (loc-x curloc))
1415                            (- (loc-y newloc) (loc-y curloc)))
1416             #t))))
1417
1418   (and
1419    (is-bad-loc? kchar (kern-obj-get-location kchar))
1420    (move-to-good-tile)))
1421
1422 (define (move-away-from-foes? kchar)
1423   ;;(println "move-away-from-foes?")
1424   (evade kchar (all-visible-hostiles kchar)))
1425
1426 ;; random-loc -- choose a random location
1427 (define (random-loc kplace x y w h)
1428   (mk-loc kplace
1429           (+ x (modulo (random-next) w))
1430           (+ y (modulo (random-next) h))))
1431
1432 ;; random-loc -- choose a random location anywhere in the given place
1433 (define (random-loc-in-place kplace)
1434   (random-loc kplace
1435               0
1436               0
1437               (kern-place-get-width kplace)
1438               (kern-place-get-height kplace)))
1439
1440 ;; random-loc-place-iter -- try up to n times to find a random location which
1441 ;; satisfies pred?
1442 (define (random-loc-place-iter kplace pred? n)
1443   (if (<= n 0)
1444       nil
1445       (let ((loc (random-loc-in-place kplace)))
1446         (if (pred? loc)
1447             loc
1448             (random-loc-place-iter kplace pred? (- n 1))))))
1449
1450 (define (is-floor? loc)
1451   (let ((kter (kern-place-get-terrain loc)))
1452     (or (eqv? kter t_flagstones)
1453         (eqv? kter t_cobblestone))))
1454
1455 (define (loc-is-empty? loc)
1456   (null? (kern-get-objects-at loc)))
1457
1458 (define (mean-player-party-level)
1459   (let ((members (kern-party-get-members (kern-get-player))))
1460     (if (= 0 (length members))
1461         1
1462         (/ (foldr (lambda (sum kchar)
1463                     ;;(println "level:" (kern-char-get-level kchar))
1464                     (+ sum (kern-char-get-level kchar)))
1465                   0
1466                   members)
1467            (length members)))))
1468
1469 (define (calc-level)
1470   (max 1
1471        (+ (mean-player-party-level)
1472           (num-player-party-members)
1473           (kern-dice-roll "1d5-3"))))
1474
1475 (define (get-mech-at loc)
1476   (let ((mechs (filter kern-obj-is-mech?
1477                        (kern-get-objects-at loc))))
1478     (if (null? mechs)
1479         nil
1480         (car mechs))))
1481
1482 (define (handle-mech-at loc kchar)
1483   (let ((kmech (get-mech-at loc)))
1484     (if (null? kmech)
1485         #f
1486         (signal-kobj kmech 'handle kmech kchar))))
1487
1488 (define (get-place kobj)
1489   (loc-place (kern-obj-get-location kobj)))
1490
1491 ;; xp to reach the given level
1492 (define (power base exp)
1493   (if (= 0 exp)
1494       1
1495       (* base (power base (- exp 1)))))
1496
1497 (define (lvl-xp lvl)
1498   (power 2 (+ 5 lvl)))
1499
1500 (define (random-faction)
1501   (modulo (random-next) faction-num))
1502
1503 (define (get-target-loc caster range)
1504   (kern-ui-target (kern-obj-get-location caster)
1505                   range))
1506
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)
1513     kgate))
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)
1524   (kern-map-repaint)
1525   (kern-sleep 250)
1526   (kern-obj-relocate kchar (loc-offset loc dir) nil)
1527   (kern-being-set-base-faction kchar faction)
1528   (kern-map-repaint))
1529
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))
1536          (car sprites)
1537          (cdr sprites)))
1538
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)
1544                                                    nil)
1545                                 (cdr sprites))))
1546
1547 ;   (foldr (lambda (s1 s2) (kern-sprite-append-decoration s1 s2))
1548 ;          (kern-sprite-clone (car sprites) nil)
1549 ;          (cdr sprites)))
1550
1551 (define (kchar-in-vehicle? kchar)
1552   (let ((kparty (kern-char-get-party kchar)))
1553     (if (null? kparty)
1554         #f
1555         (not (null? (kern-party-get-vehicle kparty))))))
1556
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))
1561      64))
1562
1563 ;; Convenience wrapper for kern-obj-add-to-inventory
1564 (define (give kpc ktype quantity)
1565   (kern-obj-add-to-inventory kpc ktype quantity))
1566
1567 ;; Convenience wrapper for kern-obj-remove-from-inventory
1568 (define (take kobj ktype quantity)
1569   (kern-obj-remove-from-inventory kobj ktype quantity))
1570
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))
1574
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)))))
1583
1584 (define (set-wind-north)
1585   (println "set-wind-north")
1586   (kern-set-wind north 10))
1587
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)
1598             (else
1599              (if (and (char=? #\x (car tokens))
1600                        (char=? #\# (cadr tokens)))
1601                  (begin
1602                    (kern-obj-put-at (mk-blocker) (list kplace x y))
1603                  ))
1604              (docol (+ x 1) (cdddr tokens)))))
1605     (cond ((null? lines) nil)
1606           (else
1607            (docol 0 (string->list (car lines)))
1608            (doline (+ y 1) (cdr lines)))))
1609     (doline 0 map))
1610
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)
1618           (else
1619            (nearest-obj kchar objects)))))
1620
1621 ;; Return an integer describing the sign of x
1622 (define (sgn x)
1623   (cond ((> x 0) 1)
1624         ((< x 0) -1)
1625         (else 0)))
1626
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))
1631          (dy (- y2 y1))
1632          (adx (abs dx))
1633          (ady (abs dy))
1634          (sdx (sgn dx))
1635          (sdy (sgn dy))
1636          (x (/ ady 2))
1637          (y (/ adx 2))
1638          (px x1)
1639          (py y1))
1640     (define (f1 i)
1641       ;;(println "f1 i=" i " px=" px " py=" py)
1642       (cond ((>= i adx)
1643              nil)
1644             (else
1645              (set! y (+ y ady))
1646              (cond ((>= y adx)
1647                     (set! y (- y adx))
1648                     (set! py (+ py sdy))))
1649              (set! px (+ px sdx))
1650              (cons (cons px py)
1651                    (f1 (+ 1 i))))))
1652     (define (f2 i)
1653       ;;(println "f2 i=" i " px=" px " py=" py)
1654       (cond ((>= i ady)
1655              nil)
1656             (else
1657              (set! x (+ x adx))
1658              (cond ((>= x ady)
1659                     (set! x (- x ady))
1660                     (set! px (+ px sdx))))
1661              (set! py (+ py sdy))
1662              (cons (cons px py)
1663                    (f2 (+ 1 i))))))
1664     (cond ((>= adx ady)
1665            (cons (cons x1 y1) (f1 0)))
1666           (else
1667            (cons (cons x1 y1) (f2 0))))))
1668
1669 ;; Utility for generating dice from numbers easily
1670 ;;
1671 (define (mkdice dice size)
1672         (let ((numstr (if (number? dice)
1673                                                 (number->string dice)
1674                                                 dice))
1675                         (sizestr (if (number? size)
1676                                                 (number->string size)
1677                                                 size)))
1678                         (string-append numstr "d" sizestr)))
1679
1680 ;; output for effects that should only be noted if visible
1681
1682 (define (msg-log-visible loc . args)
1683         (if (kern-place-is-visible? loc)
1684                 (apply kern-log-msg args)
1685                 )
1686         )
1687
1688 ;; Print dots across the console (similar to the u4 shrine meditation)
1689 (define (log-dots n delay)
1690   (define (dots n)
1691     (cond ((> n 0)
1692            (kern-log-continue ".")
1693            (kern-log-flush)
1694            (kern-sleep delay)
1695            (dots (- n 1)))))
1696   (kern-log-begin)
1697   (dots n)
1698   (kern-log-end)
1699   )
1700
1701 (define (find-first fn? lst)
1702   (if (null? lst)
1703       nil
1704       (if (fn? (car lst))
1705           (car lst)
1706           (find-first fn? (cdr lst)))))
1707
1708 (define (append! lst val)
1709   (cond ((null? lst) nil)
1710         ((null? (cdr lst)) (set-cdr! lst val))
1711         (else (append! (cdr lst) val))))
1712
1713 (define (repeat fn n)
1714   (if (> n 0)
1715       (begin
1716         (fn)
1717         (repeat fn (- n 1)))))
1718
1719 (define (string-lower str)
1720   (list->string (map char-downcase (string->list str))))
1721
1722 (define (!= a b)
1723   (not (= a b)))
1724
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))
1729
1730 (define (rect-down r v)
1731   (list (rect-x r) (+ v (rect-y r)) (rect-w r) (rect-h r)))
1732
1733 (define (rect-crop-down r v)
1734   (list (rect-x r) (+ v (rect-y r)) (rect-w r) (- (rect-h r) v)))
1735
1736 (define (rect-offset r x y)
1737   (list (+ x (rect-x r)) (+ y (rect-y r)) (rect-w r) (rect-h r)))
1738
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)))
1741
1742 (define (1- x) (- x 1))
1743 (define (1+ x) (+ x 1))
1744
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")))
1748     (or (= 20 roll)
1749         (> (+ roll bonus) dc))))
1750