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                 "¤Ï"
 523                 (kern-type-get-name ktype)
 524                 "¤ò»È¤Ã¤¿¡£")
 525   #t)
 526
 527 ;;============================================================================
 528 ;; Modulo system procedures -- useful on wrapping maps
 529 ;;============================================================================
 530 (define (madd a b R) (modulo (+ a b) R))
 531 (define (msub a b R) (modulo (- a b) R))
 532 (define (minc a R) (modulo (+ a 1) R))
 533 (define (mdec a R) (modulo (- a 1) R))
 534
 535 ;;----------------------------------------------------------------------------
 536 ;; mdist - find the distance between two numbers in a modulo system. There are
 537 ;; always 2 distances (additive and subtractive). This picks the shortest
 538 ;; distance..
 539 ;;----------------------------------------------------------------------------
 540 (define (mdist a b R) (min (msub a b R) (msub b a R)))
 541
 542 ;; ----------------------------------------------------------------------------
 543 ;; Turn on/off verbose scheme garbage collection. Useful if you think scheme is
 544 ;; gc'ing some of your code behind your back.
 545 ;; ----------------------------------------------------------------------------
 546 (gc-verbose #t)
 547
 548 (define (profile proc . args)
 549   (let ((t (kern-get-ticks))
 550         (result (apply proc args)))
 551     ;;(display "*** TIME: ");;(display (- (kern-get-ticks) t)) ;;(display " ms")
 552     (newline)
 553     result))
 554
 555 ;; ----------------------------------------------------------------------------
 556 ;; find-object-types-at -- return a list of objects of the given type which can
 557 ;; be found at the given location
 558 ;; ----------------------------------------------------------------------------
 559 (define (find-object-types-at loc ktype)
 560   (filter (lambda (a) (kobj-is-type? a ktype))
 561           (kern-get-objects-at loc)))
 562
 563 ;; ----------------------------------------------------------------------------
 564 ;; is-object-type-at? -- check for an object (by type) at a location
 565 ;; ----------------------------------------------------------------------------
 566 (define (is-object-type-at? loc ktype)
 567   (foldr (lambda (a b) (or a (kobj-is-type? b ktype)))
 568          #f
 569          (kern-get-objects-at loc)))
 570
 571 ;; ----------------------------------------------------------------------------
 572 ;; any-object-types-at? -- returns #t iff one or more objects at loc is of one
 573 ;; of the given types
 574 ;; ----------------------------------------------------------------------------
 575 (define (any-object-types-at? loc ktypes)
 576   (foldr (lambda (a b) (or a (is-object-type-at? loc b)))
 577          #f
 578          ktypes))
 579
 580 ;; is-player-party-member? -- #t iff kchar is in player party
 581 (define (is-player-party-member? kchar)
 582   (in-list? kchar
 583             (kern-party-get-members (kern-get-player))))
 584
 585 ;; ----------------------------------------------------------------------------
 586 ;; kobj-get -- remove an object from the map and put it into another object
 587 ;; ----------------------------------------------------------------------------
 588 (define (kobj-get kobj kchar)
 589   (if (kern-obj-put-into kobj kchar)
 590       (begin
 591         (if (not (is-player-party-member? kchar))
 592             (kern-log-msg (kern-obj-get-name kchar)
 593                           "¤Ï"
 594                           (kern-obj-get-name kobj)
 595                           "¤ò¼è¤Ã¤¿¡£"))
 596         (kern-obj-inc-ref kobj)
 597         (kern-obj-remove kobj)
 598         (kern-obj-dec-ref kobj)
 599         (kern-obj-dec-ap kchar (/ norm 5))
 600         (kern-map-repaint))))
 601
 602 ;; ----------------------------------------------------------------------------
 603 ;; kobj-get-at -- get an object of a specific type from the location
 604 ;; ----------------------------------------------------------------------------
 605 (define (kobj-get-at kchar loc ktype)
 606   (let ((objs (find-object-types-at loc ktype)))
 607     (if (notnull? objs)
 608         (kobj-get (car objs) kchar))))
 609
 610 ;; ----------------------------------------------------------------------------
 611 ;; place-random-corner -- randomly select a corner and return it as a location
 612 ;; ----------------------------------------------------------------------------
 613 (define (place-random-corner kplace)
 614   (case (kern-dice-roll "1d4")
 615     ((1) (mk-loc kplace  0  0))
 616     ((2) (mk-loc kplace  0  (- (kern-place-get-width kplace 1))))
 617     ((3) (mk-loc kplace  (- (kern-place-get-height kplace) 1) 0))
 618     ((4) (mk-loc kplace
 619                  (- (kern-place-get-height kplace) 1)
 620                  (- (kern-place-get-width kplace) 1)))))
 621
 622 ;; ----------------------------------------------------------------------------
 623 ;; do-or-goto -- if the location is adjacent then the proc, otherwise have
 624 ;; the char pathfind to it
 625 ;; ----------------------------------------------------------------------------
 626 (define (do-or-goto kchar coords proc)
 627   ;;;(display "do-or-goto")(newline)
 628   (if (or (loc-4-adjacent? (kern-obj-get-location kchar) coords)
 629           (eq? coords (kern-obj-get-location kchar)))
 630       (proc kchar coords)
 631       (pathfind kchar coords)))
 632
 633 ;; ----------------------------------------------------------------------------
 634 ;; evade -- simple alg for evading melee foes
 635 ;;
 636 ;; Simple approach: each foe's coordinates forms a vector to the char's
 637 ;; coordinates. Take the sum of these coordinates to get the evasion
 638 ;; vector. "Normalize" the vector components by rounding them to the nearest 0,
 639 ;; 1 or -1. This is the dx/dy to move. If the terrain is impassable in the
 640 ;; preferred direction then try zeroing out the non-zero components and
 641 ;; moving. This will give two backup vectors to try.
 642 ;;
 643 ;; ADDENDUM: I don't want to allow diagonal evasion, so the "normalized" vector
 644 ;; must be skipped if it's a diagonal, thus causing us to try the fallbak
 645 ;; vector(s).
 646 ;;
 647 ;; Now allowing diagonals, since that factor has changed
 648 ;;
 649 ;; TODO: probably shouldnt flee over dangerous terrains
 650 ;;
 651 ;; ----------------------------------------------------------------------------
 652 (define (evade kchar foes)
 653   (let* ((tloc (kern-obj-get-location kchar))
 654          (v (loc-canonical
 655                                 (foldr
 656                                         (lambda (accum thisfoe)
 657                                                 (loc-sum accum
 658                                                         (loc-diff (kern-obj-get-location thisfoe) tloc)
 659                                                 ))
 660                                         (mk-loc (loc-place tloc) 0 0)
 661                                         foes)
 662                                 ))
 663                         )
 664                 (define (move dx dy)
 665                         (if (kern-place-is-passable
 666                                         (loc-sum
 667                                                 (mk-loc (loc-place tloc) dx dy)
 668                                                 tloc)
 669                                         kchar)
 670                                 (kern-obj-move kchar dx dy)
 671                                 #f))
 672                 (define (evade-on-normal)
 673                                 (move (loc-x v) (loc-y v)))
 674
 675                 (or (evade-on-normal)
 676                         (and (not (eq? 0 (loc-y v)))
 677                                 (move (loc-x v) 0))
 678                         (and (not (eq? 0 (loc-x v)))
 679                                 (move 0 (loc-y v))))
 680                 ))
 681
 682
 683 ;; ----------------------------------------------------------------------------
 684 ;; closest-obj -- given an origin and a list of objects, return the object from
 685 ;; the list that is closest (in city-block distance) to the origin
 686 ;; ----------------------------------------------------------------------------
 687 (define (closest-obj origin lst)
 688   (if (null? lst) nil
 689       (foldr (lambda (a b)
 690                (if (loc-closer? (kern-obj-get-location a)
 691                                 (kern-obj-get-location b)
 692                                 origin)
 693                    a
 694                    b))
 695                (car lst)
 696                (cdr lst))))
 697
 698 ;; ----------------------------------------------------------------------------
 699 ;; blit-maps -- blit multiple maps to a single target map
 700 ;; ---------------------------------------------------------------------------
 701 (define (blit-maps kmap . blits)
 702   (define (blit dstx dsty srcmap srcx srcy w h)
 703     (kern-blit-map kmap dstx dsty srcmap srcx srcy w h))
 704   (foldr (lambda (a b) (apply blit b))
 705          kmap
 706          blits))
 707
 708 (define (fill-terrain-prob kter kplace ox oy ow oh prob)
 709   (define (fill x y w h)
 710     (if (> h 0)
 711         (if (> w 0)
 712             (begin
 713               (if (<= (modulo (random-next)
 714                               100)
 715                       prob)
 716                   (kern-place-set-terrain (list kplace x y) kter))
 717               (fill (+ x 1) y (- w 1) h))
 718             (fill ox (+ y 1) ow (- h 1)))))
 719   (fill ox oy ow oh))
 720
 721 (define (fill-terrain kter kplace ox oy ow oh)
 722   (fill-terrain-prob kter kplace ox oy ow oh 100))
 723
 724 ;;============================================================================
 725 ;; rect
 726 ;;============================================================================
 727 (define (mk-rect x y w h) (list x y w h))
 728 (define (rect-x r) (car r))
 729 (define (rect-y r) (cadr r))
 730 (define (rect-w r) (caddr r))
 731 (define (rect-h r) (cadddr r))
 732 (define (rect-ex r) (+ (rect-x r) (rect-w r)))
 733 (define (rect-ey r) (+ (rect-y r) (rect-h r)))
 734 (define (x-in-rect? x r)
 735   (and (>= x (rect-x r))
 736        (< x (rect-ex r))))
 737 (define (y-in-rect? y r)
 738   (and (>= y (rect-y r))
 739        (< y (rect-ey r))))
 740 (define (xy-in-rect? x y r)
 741   (and (x-in-rect? x r)
 742        (y-in-rect? y r)))
 743 (define (rect-in-rect? a b)
 744   (and (xy-in-rect? (rect-x a) (rect-y a) b)
 745        (xy-in-rect? (rect-ex a) (rect-ey a) b)))
 746 (define (loc-in-rect? loc rect)
 747   (xy-in-rect? (loc-x loc)
 748                (loc-y loc)
 749                rect))
 750 (define (rect-random rect)
 751   (list (+ (rect-x rect) (modulo (random-next) (rect-w rect)))
 752         (+ (rect-y rect) (modulo (random-next) (rect-h rect)))))
 753
 754 ;;;; (define original-load load)
 755 ;;;; (define (load file)
 756 ;;;;    (display (kern-get-ticks))
 757 ;;;;    (display " loading ")
 758 ;;;;    (display file)(newline)
 759 ;;;;    (original-load file))
 760
 761 (define (put obj x y) (list obj x y))
 762
 763 ;; lookup-spell-by-handler -- find a spell in the list of all spells
 764 (define (lookup-spell handler)
 765   (define (search-spells slist)
 766     (if (null? slist)
 767         nil
 768         (let ((spell (car slist)))
 769           (if (eqv? (spell-handler spell)
 770                     handler)
 771               spell
 772               (search-spells (cdr slist))))))
 773   (search-spells spells))
 774
 775 ;; generic lookup
 776 (define (lookup this? slist)
 777   (if (null? slist)
 778       nil
 779       (if (this? (car slist))
 780           (car slist)
 781           (lookup this? (cdr slist)))))
 782
 783 ;; can-cast -- check if a char has enough mana to cast a spell
 784 (define (can-cast? kchar handler)
 785   (let ((spell (lookup-spell handler)))
 786     (if (null? spell)
 787         #f
 788         (and (>= (kern-char-get-mana kchar)
 789                  (spell-cost spell))
 790              (>= (kern-char-get-level kchar)
 791                  (spell-level spell))))))
 792
 793 ;; cast0 - cast a spell which requires no args if possible, assumes kchar has
 794 ;; enough mana
 795 (define (cast0 kchar spell)
 796   (apply (spell-handler spell) (list kchar))
 797   (kern-char-dec-mana kchar (spell-cost spell))
 798   (kern-obj-dec-ap kchar (spell-ap spell))
 799   (kern-log-msg (kern-obj-get-name kchar)
 800                 "¤Ï"
 801                 (spell-name spell)
 802                 "¤ò¾§¤¨¤¿¡£"))
 803
 804 ;; cast1 - cast a spell which requires one arg if possible, assumes kchar has
 805 ;; enough mana
 806 (define (cast1 kchar spell ktarg)
 807   ;;;(display "cast1: ");;(display spell)(newline)
 808   (apply (spell-handler spell) (list kchar ktarg))
 809   (kern-char-dec-mana kchar (spell-cost spell))
 810   (kern-obj-dec-ap kchar (spell-ap spell))
 811   (kern-log-msg (kern-obj-get-name kchar)
 812                 "¤Ï"
 813                 (spell-name spell)
 814                 "¤ò"
 815                 (kern-obj-get-name ktarg)
 816                 "¤Ë¾§¤¨¤¿¡ª"))
 817
 818 ;; ----------------------------------------------------------------------------
 819 ;; terrain-ok-for-field? -- check if the terrain at a given location will allow
 820 ;; a field to be dropped on it. Terrains with passability class equivalent to
 821 ;; Grass, trees and forest are ok, everything else is not.
 822 ;; ----------------------------------------------------------------------------
 823 (define (terrain-ok-for-field? loc)
 824   (let ((kter (kern-place-get-terrain loc)))
 825     (println "kter: " kter)
 826     (if (null? kter)
 827         #f
 828         (let ((pclass (kern-terrain-get-pclass kter)))
 829           (foldr (lambda (a b) (or a (= pclass b)))
 830                  #f
 831                  (list pclass-grass pclass-trees pclass-forest))))))
 832
 833 (define (get-8-neighboring-tiles loc)
 834   (let ((kplace (loc-place loc))
 835         (x (loc-x loc))
 836         (y (loc-y loc)))
 837     (filter kern-is-valid-location?
 838             (map (lambda (offset) (mk-loc kplace
 839                                           (+ (car offset) x)
 840                                           (+ (cdr offset) y)))
 841                  (list (cons -1 -1)
 842                        (cons  0 -1)
 843                        (cons  1 -1)
 844                        (cons -1  0)
 845                        (cons  1  0)
 846                        (cons -1  1)
 847                        (cons  0  1)
 848                        (cons  1  1))))))
 849
 850 (define (get-4-neighboring-tiles loc)
 851   (let ((kplace (loc-place loc))
 852         (x (loc-x loc))
 853         (y (loc-y loc)))
 854     (filter kern-is-valid-location?
 855             (map (lambda (offset) (mk-loc kplace
 856                                           (+ (car offset) x)
 857                                           (+ (cdr offset) y)))
 858                  (list (cons  0 -1)
 859                        (cons -1  0)
 860                        (cons  1  0)
 861                        (cons  0  1)
 862                        )))))
 863
 864 (define (shake-map dur)
 865   (if (> dur 0)
 866       (begin
 867         (kern-map-set-jitter #t)
 868         (kern-map-repaint)
 869         (shake-map (- dur 1)))
 870       (begin
 871         (kern-map-set-jitter #f)
 872         (kern-map-repaint))))
 873
 874 (define (random-vdir)
 875   (random-select (list (cons -1 0)
 876                        (cons 1 0)
 877                        (cons 0 -1)
 878                        (cons 0 1))))
 879
 880 (define (random-neighbor-loc kobj)
 881   (let ((vdir (random-vdir)))
 882     (loc-sum (kern-obj-get-location kobj)
 883              (mk-loc nil (car vdir) (cdr vdir)))))
 884
 885 (define (push kobj dx dy dist)
 886   (let* ((loc (loc-sum (kern-obj-get-location kobj)
 887                        (mk-loc nil dx dy))))
 888     (if (and (kern-place-is-passable loc kobj)
 889              (not (occupied? loc)))
 890         (begin
 891           (kern-obj-relocate kobj loc nil)
 892           #t)
 893         #f)))
 894
 895 (define (stagger kchar)
 896   (let ((vdir (random-vdir)))
 897     (push kchar (car vdir) (cdr vdir) 1)))
 898
 899 (define (end-turn kobj)(kern-obj-set-ap kobj 0))
 900
 901 (define (add-effect-multiple kobj keff fgob q)
 902   (if (> q 0)
 903       (begin
 904         (kern-obj-add-effect kobj keff fgob)
 905         (add-effect-multiple kobj keff fgob (- q 1)))))
 906
 907 ;; time procs for use with return value from kern-get-time:
 908 (define (time-mk yr mo we da hr mi)
 909   (list yr mo we da hr mi))
 910 (define (time-year time) (list-ref time 0))
 911 (define (time-month time) (list-ref time 1))
 912 (define (time-week time) (list-ref time 2))
 913 (define (time-day time) (list-ref time 3))
 914 (define (time-hour time) (list-ref time 4))
 915 (define (time-minute time) (list-ref time 5))
 916
 917 ;; wants-healing? -- check if a char is <= 50% max hp
 918 (define (wants-healing? kchar)
 919   (<= (kern-char-get-hp kchar)
 920       (/ (kern-char-get-max-hp kchar) 2)))
 921
 922 ;; wants-healing? -- check if a char is <= 25% max hp
 923 (define (wants-great-healing? kchar)
 924   (<= (kern-char-get-hp kchar)
 925       (/ (kern-char-get-max-hp kchar) 4)))
 926
 927 ;; wants-mana? -- check if a char is <= 50% max mana
 928 (define (wants-mana? kchar)
 929   (<= (kern-char-get-mana kchar)
 930       (/ (kern-char-get-max-mana kchar) 2)))
 931
 932 ;; has-mana-potion? -- check if a char has a mana potion in inventory
 933 (define (has-mana-potion? kchar)
 934   (in-inventory? kchar t_mana_potion))
 935
 936 ;; drink-mana-potion -- use a mana potion from inventory
 937 (define (drink-mana-potion kchar)
 938   (use-item-from-inventory-on-self kchar t_mana_potion))
 939
 940 ;; has-heal-potion? -- check if a char has a heal potion in inventory
 941 (define (has-heal-potion? kchar)
 942   (in-inventory? kchar t_heal_potion))
 943
 944 ;; drink-heal-potion -- use a heal potion from inventory
 945 (define (drink-heal-potion kchar)
 946   (use-item-from-inventory-on-self kchar t_heal_potion))
 947
 948 (define (set-max-hp kchar)
 949   (kern-char-set-hp kchar
 950                     (kern-char-get-max-hp kchar)))
 951
 952 ;; max-hp -- calc max hp given species, level and occ
 953 (define (max-hp sp occ lvl mod mult)
 954   (+ (kern-species-get-hp-mod sp)
 955      (if (null? occ) 0 (kern-occ-get-hp-mod occ))
 956      mod
 957      (* lvl
 958         (+ (kern-species-get-hp-mult sp)
 959            (if (null? occ) 0 (kern-occ-get-hp-mult occ))
 960            mult))))
 961
 962 ;; max-mp -- calc max mp given species, level and occ
 963 (define (max-mp sp occ lvl mod mult)
 964   (+ (kern-species-get-mp-mod sp)
 965      (if (null? occ) 0 (kern-occ-get-mp-mod occ))
 966      mod
 967      (* lvl
 968         (+ (kern-species-get-mp-mult sp)
 969            (if (null? occ) 0 (kern-occ-get-mp-mult occ))
 970            mult))))
 971
 972
 973 ;; set-level -- set character to level and max out hp and mana (intended for
 974 ;; new npc creation)
 975 (define (set-level kchar lvl)
 976   (kern-char-set-level kchar lvl))
 977
 978 ;; use-potion? -- use potion on self if desired and available
 979 (define (use-potion? kchar)
 980   (or (and (wants-healing? kchar)
 981            (has-heal-potion? kchar)
 982            (drink-heal-potion kchar))
 983       (and (wants-mana? kchar)
 984            (has-mana-potion? kchar)
 985            (drink-mana-potion kchar))))
 986
 987 (define (use-heal-spell-on-self? kchar)
 988   ;;;;(display "use-heal-spell-on-self?")(newline)
 989   (and (wants-healing? kchar)
 990        (can-use-ability? heal-ability kchar)
 991        (use-ability heal-ability kchar kchar)))
 992
 993 (define (use-great-heal-spell-on-self? kchar)
 994   ;;;;(display "use-great-heal-spell-on-self?")(newline)
 995   (and (wants-great-healing? kchar)
 996        (can-use-ability? great-heal-ability kchar)
 997        (use-ability great-heal-ability kchar kchar)))
 998
 999 (define (use-spell-on-self? kchar)
1000   ;;;;(display "use-spell-on-self?")(newline)
1001   (or (use-great-heal-spell-on-self? kchar)
1002       (use-heal-spell-on-self? kchar)))
1003
1004 (define (avoid-melee? kchar)
1005   ;;;;(display "avoid-melee? kchar")(newline)
1006   (let ((nearby-foes (get-hostiles-in-range kchar 1)))
1007     (if (null? nearby-foes)
1008         #f
1009         (evade kchar nearby-foes))))
1010
1011 (define (dump-char kchar)
1012   (if (null? kchar)
1013       (println "nil")
1014       (begin
1015         (println "npc: " (kern-obj-get-name kchar)
1016                  "[" (kern-char-get-level kchar) "]"
1017                  " hp=" (kern-char-get-hp kchar) "/" (kern-char-get-max-hp kchar)
1018                  " mp=" (kern-char-get-mana kchar) "/" (kern-char-get-max-mana kchar)
1019                  " @[" (loc-x (kern-obj-get-location kchar))
1020                  "," (loc-y (kern-obj-get-location kchar)) "]"
1021                  ))))
1022
1023
1024 (define (get-nearest-patient kchar)
1025   (let ((kloc (kern-obj-get-location kchar)))
1026     (foldr (lambda (kpatient ktarg)
1027              ;;(display "  checking ")(dump-char ktarg)
1028              (if (and (wants-healing? ktarg)
1029                       (or (null? kpatient)
1030                           (< (kern-get-distance kloc
1031                                                 (kern-obj-get-location ktarg))
1032                              (kern-get-distance kloc
1033                                                 (kern-obj-get-location kpatient)))))
1034                  ktarg
1035                  kpatient))
1036            nil
1037            (all-visible-allies kchar))))
1038
1039 ;; This is for medics. A patient is an ally that needs healing. If a patient is
1040 ;; less than 2 tiles away then do nothing. If a patient is more than 2 tiles
1041 ;; away then pathfind toward it.
1042 (define (move-toward-patient? kchar)
1043   (let ((patient (get-nearest-patient kchar)))
1044     (if (null? patient)
1045         #f
1046         (begin
1047           ;;(display "selected ")(dump-char patient)
1048           (if (in-range? (kern-obj-get-location kchar)
1049                          2
1050                          patient)
1051               #f
1052               (pathfind kchar (kern-obj-get-location patient)))))))
1053
1054 (define (prompt-for-key)
1055   (kern-log-msg "<²¿¤«¥¡¼¤ò²¡¤¹¤ÈÂ³¤¯>")
1056   (kern-ui-waitkey))
1057
1058 (define (ship-at? loc) (not (null? (kern-place-get-vehicle loc))))
1059
1060 (define (take-player-gold q)
1061   (kern-player-set-gold (- (kern-player-get-gold) q)))
1062
1063 (define (give-player-gold q)
1064   (kern-player-set-gold (+ (kern-player-get-gold) q)))
1065
1066 (define (player-has-gold? q)
1067   (>= (kern-player-get-gold) q))
1068
1069 ;; services -- used with trade-service below
1070 (define (svc-mk name price proc) (list name price proc))
1071 (define (svc-name svc) (car svc))
1072 (define (svc-price svc) (cadr svc))
1073 (define (svc-proc svc) (caddr svc))
1074
1075 ;; some standard healer services
1076 (define (heal-service kchar knpc)
1077   ;;(display "heal-service")(newline)
1078   (let ((hp (- (kern-char-get-max-hp kchar)
1079                (kern-char-get-hp kchar))))
1080     (if (> hp 0)
1081         (begin
1082           (say knpc "¥ô¥¡¥¹¡¦¥Þ¥Ë<VAS MANI>¡ª"
1083                (kern-obj-get-name kchar) "¤ËÌþ¤·¤ò¡ª")
1084           (kern-map-flash hp)
1085           (kern-obj-heal kchar hp)
1086           #t)
1087         (begin
1088           (say knpc (kern-obj-get-name kchar)
1089                "¤Ï½ý¤Ä¤¤¤Æ¤¤¤Ê¤¤¡ª")
1090           (prompt-for-key)
1091           #f))))
1092
1093 (define (cure-service kchar knpc)
1094   ;;(display "cure-service")(newline)
1095   (if (is-poisoned? kchar)
1096       (begin
1097         (say knpc "¥¢¥ó¡¦¥Î¥¯¥¹<AN NOX>¡ª"
1098              (kern-obj-get-name kchar) "¤Ï¼£Ìþ¤µ¤ì¤¿¡£")
1099         (kern-map-flash 1)
1100         (kern-obj-remove-effect kchar ef_poison))
1101       (begin
1102         (say knpc (kern-obj-get-name kchar)
1103              "¤ÏÆÇ¤ËÈÈ¤µ¤ì¤Æ¤¤¤Ê¤¤¡ª")
1104         (prompt-for-key)
1105         #f)))
1106
1107 (define (resurrect-service kchar knpc)
1108   ;;(display "resurrect-service")(newline)
1109   (if (is-dead? kchar)
1110       (begin
1111        (say knpc "¥¤¥ó¡¦¥Þ¥Ë¡¦¥³¡¼¥×<IN MANI CORP>¡ª"
1112             (kern-obj-get-name kchar) "¤è¡¢¤è¤ß¤¬¤¨¤ì¡ª")
1113        (kern-map-flash 500)
1114        (resurrect kchar)
1115        (kern-obj-heal kchar 10))
1116       (begin
1117         (say knpc (kern-obj-get-name kchar)
1118              "¤Ï»à¤ó¤Ç¤¤¤Ê¤¤¡ª")
1119         (prompt-for-key)
1120         #f)))
1121
1122 ;; trade-services -- take a list of services which operate on a party member
1123 ;; and prompt the player, check prices, and otherwise handle the transaction
1124 (define (trade-services knpc kpc services)
1125
1126   (define (list-services)
1127     (map (lambda (svc)
1128            (string-append (svc-name svc)
1129                           "...¶â²ß"
1130                           (number->string (svc-price svc))
1131                           "Ëç"))
1132          services))
1133
1134   ;; line-name - convert a string like "Heal...30 gold" to "Heal"
1135   (define (line-name line)
1136     (define (extract l)
1137       (if (null? l)
1138           nil
1139           (if (char=? (car l) #\.)
1140               nil
1141               (cons (car l) (extract (cdr l))))))
1142     (if (null? line)
1143         nil
1144         (list->string (extract (string->list line)))))
1145
1146   (define (lookup-svc line)
1147     (let ((name (line-name line)))
1148       (if (null? name)
1149           nil
1150           (lookup (lambda (svc)
1151                     (string=? name
1152                               (svc-name svc)))
1153                   services))))
1154
1155   (define (choose-svc)
1156     (lookup-svc (apply kern-ui-select-from-list (list-services))))
1157
1158   (let ((svc (choose-svc)))
1159
1160     (define (can-pay?)
1161       (if (player-has-gold? (svc-price svc))
1162           #t
1163           (begin
1164             (say knpc "ÎÁ¶â¤¬Â¤ê¤Ê¤¤¡ª")
1165             #f)))
1166
1167     (define (apply-svc)
1168       (let ((kchar (kern-ui-select-party-member)))
1169         (if (null? kchar)
1170             #f
1171             (if (apply (svc-proc svc) (list kchar knpc))
1172                 (begin
1173                   (take-player-gold (svc-price svc))
1174                   #t)))))
1175
1176     (and (not (null? svc))
1177          (can-pay?)
1178          (apply-svc))))
1179
1180 ;; player-out-of-sight -- no LOS between kobj and any party member
1181 (define (player-out-of-sight? kobj)
1182   (define (can-see? members)
1183     (if (null? members)
1184         #f
1185         (or (kern-in-los? (kern-obj-get-location (car members))
1186                           (kern-obj-get-location kobj))
1187             (can-see? (cdr members)))))
1188   (not (can-see? (kern-party-get-members (kern-get-player)))))
1189
1190 (define (improve-relations kb1 kb2)
1191   (kern-dtable-inc (kern-being-get-current-faction kb1)
1192                    (kern-being-get-current-faction kb2)))
1193
1194 (define (harm-relations kb1 kb2)
1195   (kern-dtable-dec (kern-being-get-current-faction kb1)
1196                    (kern-being-get-current-faction kb2)))
1197
1198 (define (make-enemies kb1 kb2)
1199   (harm-relations kb1 kb2)
1200   (harm-relations kb1 kb2)
1201   (harm-relations kb1 kb2)
1202   (harm-relations kb1 kb2)
1203   )
1204
1205 (define (make-allies kb1 kb2)
1206   (improve-relations kb1 kb2)
1207   (improve-relations kb1 kb2)
1208   (improve-relations kb1 kb2)
1209   (improve-relations kb1 kb2)
1210   )
1211
1212 (define (is-bad-terrain-at? loc)
1213   (is-bad-terrain? (kern-place-get-terrain loc)))
1214
1215 ;; put-random-stuff -- randomly generate locations within the given rectangle
1216 ;; and, if pred? is satisfied, pass the loc to ctor.
1217 (define (put-random-stuff place rect pred? ctor n)
1218   (if (> n 0)
1219       (let ((loc (cons place (rect-random rect))))
1220         (if (pred? loc)
1221             (begin
1222               (ctor loc)
1223               (put-random-stuff place rect pred? ctor (- n 1)))
1224             (put-random-stuff place rect pred? ctor n)))))
1225
1226 (define (drop-random-corpses kplace n)
1227   (put-random-stuff kplace
1228                     (mk-rect 0 0
1229                              (kern-place-get-width kplace)
1230                              (kern-place-get-height kplace))
1231                     (lambda (loc)
1232                       (eqv? (kern-place-get-terrain loc)
1233                             t_grass))
1234                     (lambda (loc)
1235                       (kern-obj-put-at (mk-corpse-with-loot)
1236                                        loc))
1237                     n))
1238
1239 (define (webify kplace x y w h)
1240   (define (drop-web x loc)
1241     (let ((kter (kern-place-get-terrain loc)))
1242       (if (or (eqv? kter t_grass)
1243               (eqv? kter t_boulder))
1244           (kern-obj-put-at (kern-mk-obj F_web_perm 1)
1245                            loc))))
1246   (foldr-rect kplace x y w h drop-web nil))
1247
1248 ;; Fill the rectangle with objects of the given type. If pred? is not null use
1249 ;; it to filter out unsuitable locations.
1250 (define (rect-fill-with-npc kplace x y w h npct pred?)
1251   (define (drop-obj x loc)
1252     (if (or (null? pred?)
1253             (pred? loc))
1254         (kern-obj-put-at (kern-mk-obj ktype 1)
1255                          loc)))
1256 (foldr-rect kplace x y w h drop-obj #f))
1257
1258 ;; on-entry-to-dungeon-room -- generic place on-enty procedure for dungeon
1259 ;; rooms. When the player enters (or re-enters) a dungeon this looks for a
1260 ;; monster manager object and triggers it.
1261 (define (on-entry-to-dungeon-room kplace kplayer)
1262   ;;(println "on-entry-to-dungeon-room")
1263   (map (lambda (kmm)
1264          ;;(println " signal")
1265          (signal-kobj kmm 'on kmm nil))
1266        (kplace-get-objects-of-type kplace t_monman))
1267   )
1268
1269 ;; trigger anything with an 'on-entry' ifc
1270 (define (on-entry-trigger-all kplace kplayer)
1271   (map (lambda (kobj)
1272          (signal-kobj kobj 'on-entry kobj))
1273        (kern-place-get-objects kplace))
1274   )
1275
1276
1277 ;; mk-dungeon-room -- make a 19x19 dungeon room (simplified form of
1278 ;; kern-mk-place)
1279 (define (mk-dungeon-room tag name terrain . objects)
1280   (kern-mk-place tag
1281                  name
1282                  nil     ; sprite
1283                  (kern-mk-map nil 19 19 pal_expanded terrain)
1284                  #f      ; wraps
1285                  #t      ; underground
1286                  #f      ; large-scale (wilderness)
1287                  #f      ; tmp combat place
1288                  nil     ; subplaces
1289                  nil     ; neighbors
1290
1291                  ;; objects -- automatically add a monster manager
1292                  (cons (put (mk-monman) 0 0)
1293                        objects)
1294                  (list 'on-entry-to-dungeon-room) ; hooks
1295                  nil     ; edge entrances
1296                  ))
1297
1298 (define (mk-combat-map tag . terrain)
1299   (kern-mk-map tag 19 19 pal_expanded terrain))
1300
1301 (define (mk-tower tag name terrain entrances . objects)
1302   (kern-mk-place tag
1303                  name
1304                  s_keep     ; sprite
1305                  (kern-mk-map nil 19 19 pal_expanded terrain)
1306                  #f      ; wraps
1307                  #f      ; underground
1308                  #f      ; large-scale (wilderness)
1309                  #f      ; tmp combat place
1310                  nil     ; subplaces
1311                  nil     ; neighbors
1312
1313                  ;; objects -- automatically add a monster manager
1314                  (cons (put (mk-monman) 0 0)
1315                        objects)
1316                  (list 'on-entry-to-dungeon-room) ; hooks
1317                  entrances     ; edge entrances
1318                  ))
1319
1320 ;; Just like mk-tower but make the sprite configurable
1321 (define (mk-19x19-town tag name sprite terrain entrances . objects)
1322   (kern-mk-place tag
1323                  name
1324                  sprite
1325                  (kern-mk-map nil 19 19 pal_expanded terrain)
1326                  #f      ; wraps
1327                  #f      ; underground
1328                  #f      ; large-scale (wilderness)
1329                  #f      ; tmp combat place
1330                  nil     ; subplaces
1331                  nil     ; neighbors
1332                  ;; objects -- automatically add a monster manager
1333                  (cons (put (mk-monman) 0 0) objects)
1334                  (list 'on-entry-to-dungeon-room 'on-entry-trigger-all) ; hooks
1335                  entrances     ; edge entrances
1336                  ))
1337
1338
1339 ;; mk-dungeon-level -- given a 2d list of rooms, connect them up as neighbors
1340 (define (mk-dungeon-level . rooms)
1341   (define (bind-dir r1 r2 dir)
1342     (if (and (not (null? r1))
1343              (not (null? r2)))
1344         (kern-place-set-neighbor dir r1 r2)))
1345   (define (bind-row top bot)
1346     (if (not (null? top))
1347         (begin
1348           (if (not (null? (cdr top)))
1349               (bind-dir (car top) (cadr top) east))
1350           (if (null? bot)
1351               (bind-row (cdr top) nil)
1352               (begin
1353                 (bind-dir (car top) (car bot) south)
1354                 (if (not (null? (cdr bot)))
1355                     (bind-dir (car top) (cadr bot) southeast))
1356                 (if (not (null? (cdr top)))
1357                     (bind-dir (cadr top) (car bot) southwest))
1358                 (bind-row (cdr top) (cdr bot)))))))
1359   (define (bind-rooms rooms)
1360     (if (not (null? rooms))
1361         (begin
1362           (bind-row (car rooms)
1363                     (if (null? (cdr rooms))
1364                         nil
1365                         (cadr rooms)))
1366           (bind-rooms (cdr rooms)))))
1367   (bind-rooms rooms))
1368
1369
1370 (define (println . args)
1371   (map display args)
1372   (newline))
1373
1374
1375 (define (is-bad-field-at? kchar loc)
1376   (define (is-bad-field? val ktype)
1377     (or val
1378         (and (is-field? ktype)
1379              (not (is-immune-to-field? kchar ktype)))))
1380   (foldr is-bad-field?
1381          #f
1382          (kern-get-objects-at loc)))
1383
1384 (define (is-bad-loc? kchar loc)
1385   (or
1386    (is-bad-terrain-at? loc)
1387    (is-bad-field-at? kchar loc)
1388    ))
1389
1390 (define (is-good-loc? kchar loc)
1391   ;;(println "is-good-loc?")
1392   (and (passable? loc kchar)
1393        (not (occupied? loc))
1394        (not (is-bad-loc? kchar loc))))
1395
1396 (define (get-off-bad-tile? kchar)
1397   ;;(println "get-off-bad-tile")
1398
1399   (define (choose-good-tile tiles)
1400     ;;(display "choose-good-tile")(newline)
1401     (if (null? tiles)
1402         nil
1403         (if (is-good-loc? kchar (car tiles))
1404             (car tiles)
1405             (choose-good-tile (cdr tiles)))))
1406
1407   (define (move-to-good-tile)
1408     ;;(display "move-to-good-tile")(newline)
1409     (let* ((curloc (kern-obj-get-location kchar))
1410            (tiles (get-4-neighboring-tiles curloc))
1411            (newloc (choose-good-tile tiles)))
1412       (if (null? newloc)
1413           #f
1414           (begin
1415             ;;(display "moving")(newline)
1416             (kern-obj-move kchar
1417                            (- (loc-x newloc) (loc-x curloc))
1418                            (- (loc-y newloc) (loc-y curloc)))
1419             #t))))
1420
1421   (and
1422    (is-bad-loc? kchar (kern-obj-get-location kchar))
1423    (move-to-good-tile)))
1424
1425 (define (move-away-from-foes? kchar)
1426   ;;(println "move-away-from-foes?")
1427   (evade kchar (all-visible-hostiles kchar)))
1428
1429 ;; random-loc -- choose a random location
1430 (define (random-loc kplace x y w h)
1431   (mk-loc kplace
1432           (+ x (modulo (random-next) w))
1433           (+ y (modulo (random-next) h))))
1434
1435 ;; random-loc -- choose a random location anywhere in the given place
1436 (define (random-loc-in-place kplace)
1437   (random-loc kplace
1438               0
1439               0
1440               (kern-place-get-width kplace)
1441               (kern-place-get-height kplace)))
1442
1443 ;; random-loc-place-iter -- try up to n times to find a random location which
1444 ;; satisfies pred?
1445 (define (random-loc-place-iter kplace pred? n)
1446   (if (<= n 0)
1447       nil
1448       (let ((loc (random-loc-in-place kplace)))
1449         (if (pred? loc)
1450             loc
1451             (random-loc-place-iter kplace pred? (- n 1))))))
1452
1453 (define (is-floor? loc)
1454   (let ((kter (kern-place-get-terrain loc)))
1455     (or (eqv? kter t_flagstones)
1456         (eqv? kter t_cobblestone))))
1457
1458 (define (loc-is-empty? loc)
1459   (null? (kern-get-objects-at loc)))
1460
1461 (define (mean-player-party-level)
1462   (let ((members (kern-party-get-members (kern-get-player))))
1463     (if (= 0 (length members))
1464         1
1465         (/ (foldr (lambda (sum kchar)
1466                     ;;(println "level:" (kern-char-get-level kchar))
1467                     (+ sum (kern-char-get-level kchar)))
1468                   0
1469                   members)
1470            (length members)))))
1471
1472 (define (calc-level)
1473   (max 1
1474        (+ (mean-player-party-level)
1475           (num-player-party-members)
1476           (kern-dice-roll "1d5-3"))))
1477
1478 (define (get-mech-at loc)
1479   (let ((mechs (filter kern-obj-is-mech?
1480                        (kern-get-objects-at loc))))
1481     (if (null? mechs)
1482         nil
1483         (car mechs))))
1484
1485 (define (handle-mech-at loc kchar)
1486   (let ((kmech (get-mech-at loc)))
1487     (if (null? kmech)
1488         #f
1489         (signal-kobj kmech 'handle kmech kchar))))
1490
1491 (define (get-place kobj)
1492   (loc-place (kern-obj-get-location kobj)))
1493
1494 ;; xp to reach the given level
1495 (define (power base exp)
1496   (if (= 0 exp)
1497       1
1498       (* base (power base (- exp 1)))))
1499
1500 (define (lvl-xp lvl)
1501   (power 2 (+ 5 lvl)))
1502
1503 (define (random-faction)
1504   (modulo (random-next) faction-num))
1505
1506 (define (get-target-loc caster range)
1507   (kern-ui-target (kern-obj-get-location caster)
1508                   range))
1509
1510 ;;----------------------------------------------------------------------------
1511 ;; code for opening a moongate, warping in a monster, and re-closing it
1512 (define (open-moongate loc)
1513   (let ((kgate (mk-moongate nil)))
1514     (kern-obj-relocate kgate loc nil)
1515     (moongate-animate kgate moongate-stages)
1516     kgate))
1517 (define (close-moongate kgate)
1518   (moongate-animate kgate (reverse moongate-stages))
1519   (moongate-destroy kgate))
1520 (define (warp-in kchar loc dir faction)
1521   (display "warp-in")(newline)
1522   (kern-char-set-schedule kchar nil)
1523   (kern-obj-inc-ref kchar)
1524   (kern-obj-remove kchar)
1525   (kern-obj-relocate kchar loc nil)
1526   (kern-obj-dec-ref kchar)
1527   (kern-map-repaint)
1528   (kern-sleep 250)
1529   (kern-obj-relocate kchar (loc-offset loc dir) nil)
1530   (kern-being-set-base-faction kchar faction)
1531   (kern-map-repaint))
1532
1533 ;;-----------------------------------------------------------------------------
1534 ;; re-mk-composite-sprite -- combine all the sprites into one layered sprite,
1535 ;; cloning ALL BUT the first sprite. Useful for re-decorating base sprites that
1536 ;; have already been cloned.
1537 (define (re-mk-composite-sprite sprites)
1538   (foldr (lambda (s1 s2) (kern-sprite-append-decoration s1 s2))
1539          (car sprites)
1540          (cdr sprites)))
1541
1542 ;;-----------------------------------------------------------------------------
1543 ;; mk-composite-sprite -- combine all the sprites into one composite sprite,
1544 ;; cloning all the sprites in the list.
1545 (define (mk-composite-sprite sprites)
1546   (re-mk-composite-sprite (cons (kern-sprite-clone (car sprites)
1547                                                    nil)
1548                                 (cdr sprites))))
1549
1550 ;   (foldr (lambda (s1 s2) (kern-sprite-append-decoration s1 s2))
1551 ;          (kern-sprite-clone (car sprites) nil)
1552 ;          (cdr sprites)))
1553
1554 (define (kchar-in-vehicle? kchar)
1555   (let ((kparty (kern-char-get-party kchar)))
1556     (if (null? kparty)
1557         #f
1558         (not (null? (kern-party-get-vehicle kparty))))))
1559
1560 ;; is-in-darkness? -- #t iff light on this object's tile is less than the
1561 ;; threshold for "dark"
1562 (define (is-in-darkness? kobj)
1563   (< (kern-place-get-light (kern-obj-get-location kobj))
1564      64))
1565
1566 ;; Convenience wrapper for kern-obj-add-to-inventory
1567 (define (give kpc ktype quantity)
1568   (kern-obj-add-to-inventory kpc ktype quantity))
1569
1570 ;; Convenience wrapper for kern-obj-remove-from-inventory
1571 (define (take kobj ktype quantity)
1572   (kern-obj-remove-from-inventory kobj ktype quantity))
1573
1574 ;; Return #t iff object has at least that many in inventory
1575 (define (has? kobj ktype quantity)
1576   (>= (num-in-inventory kobj ktype) quantity))
1577
1578 ;; Safely if a character is in the player party. char-tag should be the
1579 ;; character's quoted scheme variable name, for example 'ch_dude.
1580 (define (in-player-party? kchar-tag)
1581   (println "in-player-party? " kchar-tag)
1582   (and (defined? kchar-tag)
1583        (let ((kchar (eval kchar-tag)))
1584          (and (is-alive? kchar)
1585               (is-player-party-member? kchar)))))
1586
1587 (define (set-wind-north)
1588   (println "set-wind-north")
1589   (kern-set-wind north 10))
1590
1591 ;; block-teleporting takes a place and a list of strings that looks
1592 ;; suspiciously like a terrain map, and uses the map to apply blocking
1593 ;; mechanisms to the place. Every "x#" entry in the map will cause a blocking
1594 ;; mechanism to be placed on that location. All other entries are ignored. The
1595 ;; blocking mechanisms prevent spells like blink from letting the player break
1596 ;; the fiction of a simulated multi-story place.
1597 (define (block-teleporting kplace map)
1598   (define (doline y lines)
1599     (define (docol x tokens)
1600       (cond ((null? tokens) nil)
1601             (else
1602              (if (and (char=? #\x (car tokens))
1603                        (char=? #\# (cadr tokens)))
1604                  (begin
1605                    (kern-obj-put-at (mk-blocker) (list kplace x y))
1606                  ))
1607              (docol (+ x 1) (cdddr tokens)))))
1608     (cond ((null? lines) nil)
1609           (else
1610            (docol 0 (string->list (car lines)))
1611            (doline (+ y 1) (cdr lines)))))
1612     (doline 0 map))
1613
1614 ;; Find the visible object of the given type nearest to the kchar.
1615 (define (find-nearest kchar ktype)
1616   (let ((objects (filter (lambda (kobj)
1617                            (and (kobj-is-type? kobj ktype)
1618                                 (can-see? kchar kobj)))
1619                          (kern-place-get-objects (loc-place (kern-obj-get-location kchar))))))
1620     (cond ((null? objects) nil)
1621           (else
1622            (nearest-obj kchar objects)))))
1623
1624 ;; Return an integer describing the sign of x
1625 (define (sgn x)
1626   (cond ((> x 0) 1)
1627         ((< x 0) -1)
1628         (else 0)))
1629
1630 ;; Return a list of (x . y) pairs that constitute a line between two
1631 ;; points. Uses Bresenhaum's line-drawing algorithm.
1632 (define (line x1 y1 x2 y2)
1633   (let* ((dx (- x2 x1))
1634          (dy (- y2 y1))
1635          (adx (abs dx))
1636          (ady (abs dy))
1637          (sdx (sgn dx))
1638          (sdy (sgn dy))
1639          (x (/ ady 2))
1640          (y (/ adx 2))
1641          (px x1)
1642          (py y1))
1643     (define (f1 i)
1644       ;;(println "f1 i=" i " px=" px " py=" py)
1645       (cond ((>= i adx)
1646              nil)
1647             (else
1648              (set! y (+ y ady))
1649              (cond ((>= y adx)
1650                     (set! y (- y adx))
1651                     (set! py (+ py sdy))))
1652              (set! px (+ px sdx))
1653              (cons (cons px py)
1654                    (f1 (+ 1 i))))))
1655     (define (f2 i)
1656       ;;(println "f2 i=" i " px=" px " py=" py)
1657       (cond ((>= i ady)
1658              nil)
1659             (else
1660              (set! x (+ x adx))
1661              (cond ((>= x ady)
1662                     (set! x (- x ady))
1663                     (set! px (+ px sdx))))
1664              (set! py (+ py sdy))
1665              (cons (cons px py)
1666                    (f2 (+ 1 i))))))
1667     (cond ((>= adx ady)
1668            (cons (cons x1 y1) (f1 0)))
1669           (else
1670            (cons (cons x1 y1) (f2 0))))))
1671
1672 ;; Utility for generating dice from numbers easily
1673 ;;
1674 (define (mkdice dice size)
1675         (let ((numstr (if (number? dice)
1676                                                 (number->string dice)
1677                                                 dice))
1678                         (sizestr (if (number? size)
1679                                                 (number->string size)
1680                                                 size)))
1681                         (string-append numstr "d" sizestr)))
1682
1683 ;; output for effects that should only be noted if visible
1684
1685 (define (msg-log-visible loc . args)
1686         (if (kern-place-is-visible? loc)
1687                 (apply kern-log-msg args)
1688                 )
1689         )
1690
1691 ;; Print dots across the console (similar to the u4 shrine meditation)
1692 (define (log-dots n delay)
1693   (define (dots n)
1694     (cond ((> n 0)
1695            (kern-log-continue ".")
1696            (kern-log-flush)
1697            (kern-sleep delay)
1698            (dots (- n 1)))))
1699   (kern-log-begin)
1700   (dots n)
1701   (kern-log-end)
1702   )
1703
1704 (define (find-first fn? lst)
1705   (if (null? lst)
1706       nil
1707       (if (fn? (car lst))
1708           (car lst)
1709           (find-first fn? (cdr lst)))))
1710
1711 (define (append! lst val)
1712   (cond ((null? lst) nil)
1713         ((null? (cdr lst)) (set-cdr! lst val))
1714         (else (append! (cdr lst) val))))
1715
1716 (define (repeat fn n)
1717   (if (> n 0)
1718       (begin
1719         (fn)
1720         (repeat fn (- n 1)))))
1721
1722 (define (string-lower str)
1723   (list->string (map char-downcase (string->list str))))
1724
1725 (define (!= a b)
1726   (not (= a b)))
1727
1728 (define (rect-x r) (car r))
1729 (define (rect-y r) (cadr r))
1730 (define (rect-w r) (caddr r))
1731 (define (rect-h r) (cadddr r))
1732
1733 (define (rect-down r v)
1734   (list (rect-x r) (+ v (rect-y r)) (rect-w r) (rect-h r)))
1735
1736 (define (rect-crop-down r v)
1737   (list (rect-x r) (+ v (rect-y r)) (rect-w r) (- (rect-h r) v)))
1738
1739 (define (rect-offset r x y)
1740   (list (+ x (rect-x r)) (+ y (rect-y r)) (rect-w r) (rect-h r)))
1741
1742 (define (rect-crop-offset r x y)
1743   (list (+ x (rect-x r)) (+ y (rect-y r)) (- (rect-w r) x) (- (rect-h r) y)))
1744
1745 (define (1- x) (- x 1))
1746 (define (1+ x) (+ x 1))
1747
1748 ;; Standard dc vs 1d20 + bonus, with a perfect roll granting automatic success.
1749 (define (check-roll dc bonus)
1750   (let ((roll (kern-dice-roll "1d20")))
1751     (or (= 20 roll)
1752         (> (+ roll bonus) dc))))
1753