worlds/haxima-1.002/powers.scm

   1 ;;--------------------------------------------------------------
   2 ;; This stuff needs to be somewhere more generic
   3 ;;--------------------------------------------------------------
   4
   5 (define pi (* 2 (acos 0)))
   6
   7 (define (xy->angle x y)
   8         (if (equal? x 0)
   9                 (cond ((> y 0) (atan 999999))
  10                         ((< y 0) (atan -999999))
  11                         (else 0))
  12                 (if (< x 0)
  13                         (+ (atan (/ y x)) pi)
  14                         (atan (/ y x)))))
  15
  16 (define (cone-in-range x y range)
  17         (< (+ (* x x) (* y y)) (* range range)))
  18
  19 (define (angle-wrap angle)
  20         (cond ((< angle 0) (angle-wrap (+ angle (* 2 pi))))
  21                 ((> angle (* 2 pi)) (angle-wrap (- angle (* 2 pi))))
  22                 (else angle)))
  23
  24 (define (angle-diff baseangle testangle)
  25         (- (angle-wrap (- testangle baseangle pi)) pi))
  26
  27 (define (cone-in-angle x y minangle maxangle)
  28         (let ((tangle (xy->angle x y)))
  29                 (if (< (angle-diff minangle maxangle) 0)
  30                         (or (>= (angle-diff minangle tangle) 0)
  31                                 (<= (angle-diff maxangle tangle) 0))
  32                         (and (>= (angle-diff minangle tangle) 0)
  33                                 (<= (angle-diff maxangle tangle) 0))
  34                         )))
  35
  36 (define (cone-get-edge x y inlist)
  37         (cons (list y x)
  38         (cons (list x y) inlist)))
  39
  40 (define (cone-get-initial n inlist)
  41         (cone-get-edge (- 0 n) 0
  42         (cone-get-edge n 0 inlist)))
  43
  44 (define (cone-get-sides n m inlist)
  45         (if (< m n)
  46                 (cone-get-sides n (+ m 1)
  47                         (cone-get-edge n m
  48                         (cone-get-edge (- 0 n) m
  49                         (cone-get-edge n (- 0 m)
  50                         (cone-get-edge (- 0 n) (- 0 m) inlist))))
  51                 )
  52                 inlist))
  53
  54 (define (cone-get-corners n inlist)
  55         (cons (list n n)
  56         (cons (list (- 0 n) (- 0 n) )
  57         (cone-get-edge (- 0 n) n inlist))))
  58
  59 (define (cone-get-box n)
  60         (cone-get-sides n 1
  61         (cone-get-corners n
  62         (cone-get-initial n nil))))
  63
  64 (define (cone-check-cell origin minangle maxangle range proc cell)
  65         (let* ((x (car cell))
  66                         (y (cadr cell))
  67                         (loc (list (car origin) (+ (cadr origin) x) (+ y (caddr origin)))))
  68                 (if (and (cone-in-range x y range)
  69                                         (cone-in-angle x y minangle maxangle)
  70                                         (kern-is-valid-location? loc)
  71                                         )
  72                                 (proc loc)
  73                                 )))
  74
  75
  76 (define (cone-handle-box origin minangle maxangle range proc list)
  77         (if (not (null? list))
  78                 (begin
  79                         (cone-check-cell origin minangle maxangle range proc (car list))
  80                         (cone-handle-box origin minangle maxangle range proc (cdr list))
  81                 )))
  82
  83
  84 (define (cone-area-slice n origin minangle maxangle range proc)
  85         (if (< n range)
  86                 (begin
  87                         (cone-handle-box origin minangle maxangle range proc
  88                                 (cone-get-box n))
  89                         (cone-area-slice (+ n 1) origin minangle maxangle range proc)
  90                 )))
  91
  92 (define (cone-area-effect origin angle range width proc)
  93         (let ((minangle (angle-wrap (- angle (/ width 2))))
  94                 (maxangle (angle-wrap (+ angle (/ width 2)))))
  95         (cone-area-slice 1 origin minangle maxangle range proc)
  96     ))
  97
  98 (define (cone-do-simple caster target range proc)
  99         (let* ((origin (kern-obj-get-location caster))
 100                         (x (- (cadr target) (cadr origin)))
 101                         (y (- (caddr target) (caddr origin))))
 102                 (cone-area-effect origin (xy->angle x y) range (/ pi 2) proc)
 103                 ))
 104
 105 (define (cone-simple caster range proc)
 106         (let ((origin (kern-obj-get-location caster))
 107                 (target (get-target-loc caster range)))
 108                 (if (null? target)
 109                         #f
 110                         (let ((x (- (cadr target) (cadr origin)))
 111                                 (y (- (caddr target) (caddr origin))))
 112                         (cone-area-effect origin (xy->angle x y) range (/ pi 2) proc))
 113                 )))
 114
 115 (define (powers-field-generic loc f_type duration proc)
 116         (let* ((finduration (if (< duration 1) 1 duration))
 117                         (afield (kern-mk-field f_type finduration)))
 118                 (if (can-be-dropped? afield loc cant)
 119                         (begin
 120                                 (kern-obj-put-at afield loc)
 121                                 (kern-map-repaint)
 122                                 (if (not (null? proc))
 123                                         (for-each proc (kern-get-objects-at loc))
 124                                 )
 125                                 ;; remove fields on semi-bad locations
 126                                 (if (or (< duration 1)
 127                                                 (not (can-be-dropped? afield loc no-drop)))
 128                                         (kern-obj-remove afield)
 129                                 )
 130                                 (kern-map-repaint)
 131                         ))
 132         ))
 133
 134 (define (mk-basic-cone-proc origin objfx field-type leaveproc)
 135         (define (dropfield loc)
 136                 (if (kern-obj-put-at (kern-mk-obj field-type 1) loc)))
 137         (define (is-my-field? kobj) (eqv? field-type (kern-obj-get-type kobj)))
 138         (define (cleanfields loc)
 139                 (let ((fields (filter is-my-field? (kern-get-objects-at loc)))
 140                                 (duration (leaveproc)))
 141                         (cond ((null? fields) nil)
 142                                 (else
 143                                         (kern-obj-remove (car fields))))
 144                         (if     (and (terrain-ok-for-field? loc)
 145                                         (> duration 0))
 146                                 (kern-obj-put-at (kern-mk-field field-type duration) loc))
 147                                 ))
 148         (lambda (loc)
 149                 (if (kern-in-los? origin loc)
 150                         (if (null? field-type)
 151                                 (if (not (null? objfx))
 152                                         (map objfx (kern-get-objects-at loc))
 153                                 )
 154                                 (powers-field-generic loc field-type (leaveproc) objfx)
 155                         ))
 156         ))
 157
 158 (define (mk-cone-proc-sfx origin objfx sfx field-type leaveproc)
 159         (define (dropfield loc)
 160                 (if (kern-obj-put-at (kern-mk-obj field-type 1) loc)))
 161         (define (is-my-field? kobj) (eqv? field-type (kern-obj-get-type kobj)))
 162         (define (cleanfields loc)
 163                 (let ((fields (filter is-my-field? (kern-get-objects-at loc)))
 164                                 (duration (leaveproc)))
 165                         (cond ((null? fields) nil)
 166                                 (else
 167                                         (kern-obj-remove (car fields))))
 168                         (if     (and (terrain-ok-for-field? loc)
 169                                         (> duration 0))
 170                                 (kern-obj-put-at (kern-mk-field field-type duration) loc))
 171                                 ))
 172         (lambda (loc)
 173                 (kern-sound-play-at sfx origin)
 174                 (if (kern-in-los? origin loc)
 175                         (if (null? field-type)
 176                                 (if (not (null? objfx))
 177                                         (map objfx (kern-get-objects-at loc))
 178                                 )
 179                                 (powers-field-generic loc field-type (leaveproc) objfx)
 180                         ))
 181         ))
 182
 183 ;; todo- inc these in line-cell to simplify?
 184 (define (line-do-proc proc location)
 185         (if (kern-is-valid-location? location)
 186                 (proc location 1)
 187                 #f
 188         ))
 189
 190 (define (line-diag place x y dx dy proc)
 191         (let* ((curx (floor x))
 192                         (cury (floor y))
 193                         (newx (floor (+ x (/ dx 2))))
 194                         (newy (floor (+ y (/ dy 2))))
 195                         (location (loc-mk place newx newy)))
 196                 (if (or (not (equal? newx curx))
 197                                         (not (equal? newy cury)))
 198                         (if (kern-is-valid-location? location)
 199                                 (proc location 0.5)
 200                                 #f
 201                         )
 202                         #t
 203                 )
 204         ))
 205
 206 (define (line-cell place x y dx dy endx endy proc)
 207         (let ((curx (floor x))
 208                         (cury (floor y)))
 209                 (if (and
 210                                 (if (equal? (abs dx) 1) (line-diag place x y 0 (* dy 1.0000001) proc) (line-diag place x y (* dx 1.0000001) 0 proc))
 211                                 (line-do-proc proc (loc-mk place curx cury))
 212                                 (not (and (equal? curx endx) (equal? cury endy)))
 213                                 (if (equal? (abs dx) 1) (line-diag place (+ x dx) (+ y dy) 0 (* dy -0.9999999) proc) (line-diag place (+ x dx) (+ y dy) (* dx -0.9999999) 0 proc))
 214                                 )
 215                         (line-cell place (+ x dx) (+ y dy) dx dy endx endy proc))
 216         ))
 217
 218 ;; todo will fail on looping maps
 219 (define (line-draw place startx starty stopx stopy proc)
 220         (if (and (equal? startx stopx)
 221                                 (equal? starty stopy))
 222                 (line-do-proc proc (loc-mk place startx starty))
 223                 (let* ((xdif (- stopx startx))
 224                                 (ydif (- stopy starty))
 225                                 (div (if (> (abs xdif) (abs ydif)) (abs xdif) (abs ydif)))
 226                                 (dx (/ xdif div))
 227                                 (dy (/ ydif div)))
 228                         (line-cell place (+ startx 0.5) (+ starty 0.5) dx dy stopx stopy proc)
 229                 )))
 230
 231 (define (cast-missile-proc kchar ktarg ktype)
 232   (kern-fire-missile ktype
 233                      (kern-obj-get-location kchar)
 234                      (kern-obj-get-location ktarg)))
 235
 236 ;;--------------------------------------------------------------
 237 ;; Shared utilities
 238 ;;--------------------------------------------------------------
 239
 240 (define (contest-of-skill offense defense)
 241   (let ((oprob (+ offense 1))
 242         (tprob (number->string (+ offense defense 2))))
 243     (println "oprob=" oprob " tprob=" tprob " offense=" offense " defense=" defense)
 244     (if (< (kern-dice-roll (string-append "1d" tprob))
 245            oprob)
 246           #t
 247           #f
 248         )))
 249
 250
 251 ;;--------------------------------------------------------------
 252 ;; Spells
 253 ;;--------------------------------------------------------------
 254
 255
 256 ;todo add area effect for high powered users?
 257 (define (powers-awaken caster ktarg power)
 258         (kern-obj-remove-effect ktarg ef_sleep)
 259         (kern-char-set-sleep ktarg #f)
 260         result-ok)
 261
 262 (define (powers-blink-range power)
 263         (+ 3 power))
 264
 265 (define (powers-blink caster ktarg power)
 266         (if (kern-place-is-passable ktarg caster)
 267                 (kern-obj-relocate caster ktarg nil)
 268                 (kern-log-msg "Blink Failed: Impassable terrain")
 269         )
 270         result-ok)
 271
 272 (define (powers-blink-party-range power)
 273         (cond ((< power 20) (* power 0.75))
 274                 (else 15)))
 275
 276 (define (powers-blink-party caster ktarg power)
 277         (if (kern-place-is-passable ktarg (kern-char-get-party caster))
 278                 (kern-obj-relocate (kern-char-get-party caster) ktarg nil)
 279                 (kern-log-msg "Blink Failed: Impassable terrain")
 280         )
 281         result-ok)
 282
 283 (define (powers-charm-range power)
 284         (+ 3 (/ power 3)))
 285
 286 ; (Only) failed charm pisses off target
 287 (define (powers-charm caster target power)
 288         (cond
 289          ((has-charm-immunity? target)
 290           (msg-log-visible (kern-obj-get-location target) (kern-obj-get-name target) " immune to charm")
 291           )
 292          ((contest-of-skill
 293            (+ power 1)
 294            (occ-ability-magicdef target))
 295           (let ((tloc (kern-obj-get-location target)))
 296             (kern-obj-add-effect target
 297                                  ef_charm
 298                                  (charm-mk (kern-being-get-current-faction caster)))
 299             (kern-map-flash-sprite s_heart (loc-x tloc) (loc-y tloc))
 300                                         (msg-log-visible tloc (kern-obj-get-name target) " is charmed")
 301                                         )
 302           )
 303          (else
 304           (msg-log-visible (kern-obj-get-location target) (kern-obj-get-name target) " resists charm")
 305           (kern-harm-relations target caster)
 306           )
 307          )
 308         result-ok
 309         )
 310
 311 ;; Weaker than charm, this turns the target's alignment to be that of
 312 ;; monsters. The monster faction is hostile to most others, so the player can
 313 ;; use it against outlaws, cave goblins, etc.
 314 (define (powers-beastly-illusion caster target power)
 315   (cond ((has-charm-immunity? target)
 316          (msg-log-visible (kern-obj-get-location target) (kern-obj-get-name target) " resists illusion")
 317          )
 318         ((contest-of-skill (+ power 1) (occ-ability-magicdef target))
 319          (let ((tloc (kern-obj-get-location target)))
 320            (kern-obj-add-effect target ef_charm (charm-mk faction-monster))
 321            (kern-map-flash-sprite s_heart (loc-x tloc) (loc-y tloc))
 322            (msg-log-visible tloc (kern-obj-get-name target) " is deluded")
 323            ))
 324         (else (msg-log-visible (kern-obj-get-location target) (kern-obj-get-name target) " resists illusion"))
 325         )
 326   (kern-harm-relations target caster)
 327   result-ok
 328   )
 329
 330 (define (powers-clone-range power)
 331         (+ 1 (/ power 7)))
 332
 333 (define (powers-clone caster target power)
 334         (let* ((clone (kern-obj-clone target))
 335                                 (loc (pick-loc (kern-obj-get-location target) clone)))
 336                 (kern-being-set-base-faction clone (kern-being-get-current-faction caster))
 337                 ;; clone has equipment of original
 338                 (map (lambda (ktype)
 339                         (kern-obj-add-to-inventory clone ktype 1))
 340                         (kern-char-get-arms target)
 341                 )
 342                 (kern-char-arm-self clone)
 343                 ;; clone level based on of weaker of caster or original
 344                 (if (> (kern-char-get-level target) (kern-char-get-level caster))
 345                         (kern-char-set-level clone (+ 1 (* (kern-char-get-level caster) 0.75)))
 346                         (kern-char-set-level clone (+ 1 (* (kern-char-get-level target) 0.75)))
 347                 )
 348                 ;; clone may not have more hp/mana than original
 349                 (if (> (kern-char-get-hp clone) (kern-char-get-hp target))
 350                         (kern-char-set-hp clone (kern-char-get-hp target)))
 351                 (if (> (kern-char-get-mana clone) (kern-char-get-mana target))
 352                         (kern-char-set-mana clone (kern-char-get-mana target)))
 353                 ;;(kern-char-set-ai clone 'spell-sword-ai)
 354                 (kern-obj-put-at clone loc)
 355         )
 356         result-ok)
 357
 358 (define (powers-cone-flamespray caster ktarg power)
 359         (let ((damage (mkdice 2 (min (floor (+ 2 (/ power 2))) 10))))
 360                 (define (flambe-all kobj)
 361                         (if (and (is-being? kobj)
 362                                         (not (has-fire-immunity? kobj)))
 363                                 (kern-obj-inflict-damage kobj "burning" (kern-dice-roll damage) caster)
 364                                 ))
 365                 (cone-do-simple caster ktarg 3.3
 366                         (mk-basic-cone-proc (kern-obj-get-location caster) flambe-all F_fire (lambda () 0))
 367                         ))
 368                         result-ok)
 369
 370 (define (powers-cone-basic-leaveproc balance width)
 371         (lambda ()
 372                 (- (kern-dice-roll (mkdice 1 width)) balance)))
 373
 374 ;; this may need to be limited...
 375 (define (powers-cone-basic-range power)
 376         (+ 3 (/ power 3)))
 377
 378 (define (powers-cone-fire-range power)
 379         (+ 5 (/ power 3)))
 380
 381 (define (powers-cone-energy caster ktarg power)
 382         (let ((damage (mkdice (floor (/ power 2)) 3)))
 383                 (define (energize-all kobj)
 384                         (if (is-being? kobj)
 385                                 (kern-obj-inflict-damage kobj "shocked" (kern-dice-roll damage) caster)
 386                                 ))
 387                 (cone-do-simple caster ktarg (powers-cone-basic-range power)
 388                         (mk-basic-cone-proc (kern-obj-get-location caster) energize-all F_energy
 389                                 (powers-cone-basic-leaveproc 40 (+ 30 (* 4 power)))
 390                         )))
 391                         result-ok)
 392
 393 ;; check for: no unintended victims
 394 ;;    at least 2 fire vulnerable targets
 395 (define (powers-cone-fire-test caster targloc power)
 396         ;;(println "test cone fire")
 397         (let ((viable-targets (list 0))
 398                         (shot-ok (list #t)))
 399                 (define (checktarg kobj)
 400                         (if (is-being? kobj)
 401                                 ;; test for hostility and known (ie permanent) fire resistance
 402                                 (if (is-hostile? kobj caster)
 403                                         (if (not (has-effect? kobj ef_fire_immunity))
 404                                                 (set-car! viable-targets (+ (car viable-targets) 1))
 405                                         )
 406                                         (set-car! shot-ok #f)
 407                                 )
 408                         )
 409                 )
 410                 (cone-do-simple caster targloc (powers-cone-fire-range power)
 411                         (mk-basic-cone-proc (kern-obj-get-location caster) checktarg nil nil)
 412                         )
 413                 ;;(println "tested cone fire " (car shot-ok) " " (car viable-targets))
 414                 (and (car shot-ok)
 415                         (> (car viable-targets )1))
 416         ))
 417
 418 (define (powers-cone-fire caster targloc power)
 419         (let ((damage (mkdice (floor (/ power 2)) 3)))
 420                 (define (burn-all kobj)
 421                         (if (and (is-being? kobj)
 422                                         (not (has-fire-immunity? kobj)))
 423                                 (begin
 424                                         (kern-obj-inflict-damage kobj "burning" (kern-dice-roll damage) caster)
 425                                         (kern-harm-relations kobj caster)
 426                                 )
 427                         ))
 428                 (cone-do-simple caster targloc (powers-cone-fire-range power)
 429                         (mk-cone-proc-sfx (kern-obj-get-location caster) burn-all sound-fireblast F_fire
 430                                 (powers-cone-basic-leaveproc 30 (+ 20 (* 5 power)))
 431                         )
 432                 ))
 433         result-ok
 434 )
 435
 436 (define (powers-cone-poison caster ktarg power)
 437         (let ((damage (mkdice 1 (floor (/ power 4)))))
 438                 (define (poison-all kobj)
 439                         (if (is-being? kobj)
 440                                 (begin
 441                                         (apply-poison kobj)
 442                                         (if (is-poisoned? kobj)
 443                                                 (begin
 444                                                         (kern-harm-relations kobj caster)
 445                                                         (kern-harm-relations kobj caster)
 446                                                         (kern-harm-relations kobj caster)
 447                                                         (kern-harm-relations kobj caster)
 448                                                         (kern-obj-inflict-damage kobj "poison" (kern-dice-roll damage) caster)
 449                                                 )
 450                                 ))))
 451                 (cone-do-simple caster ktarg (powers-cone-basic-range power)
 452                         (mk-basic-cone-proc (kern-obj-get-location caster) poison-all F_poison
 453                                 (powers-cone-basic-leaveproc 60 (+ 40 (* 3 power)))
 454                         )))
 455                         result-ok)
 456
 457 (define (powers-cone-sleep caster ktarg power)
 458         (let ((damage (mkdice 1 (floor (/ power 4)))))
 459                 (define (sleep-all kobj)
 460                         (if (is-being? kobj)
 461                                 (begin
 462                                         (kern-harm-relations kobj caster)
 463                                         (if (contest-of-skill
 464                                                         (+ power 8)
 465                                                         (occ-ability-magicdef kobj))
 466                                                 (apply-sleep kobj))
 467                                 )))
 468                 (cone-do-simple caster ktarg (powers-cone-basic-range power)
 469                         (mk-basic-cone-proc (kern-obj-get-location caster) sleep-all F_sleep
 470                                 (powers-cone-basic-leaveproc 40 (+ 30 (* 4 power)))
 471                         )))
 472                         result-ok)
 473
 474 ;todo limit to some range?
 475 (define (powers-confuse caster unused power)
 476         (define (confuse kchar)
 477                 (if (contest-of-skill
 478                                 power
 479                                 (+ (occ-ability-magicdef kchar) 2))
 480                         (kern-being-set-base-faction kchar (random-faction))
 481                         ))
 482         (map confuse (all-hostiles caster))
 483         result-ok)
 484
 485 (define (powers-cure-poison caster ktarg power)
 486         (kern-obj-remove-effect ktarg ef_poison)
 487         (if (< (kern-dice-roll "1d25") power)
 488             (kern-obj-remove-effect ktarg ef_disease))
 489         result-ok)
 490
 491 ;todo currently only checks topmost item
 492 (define (powers-detect-traps caster ktarg power)
 493   (let ((traps (ifccall ktarg 'get-traps)))
 494     (cond ((null? traps)
 495            (kern-log-msg (kern-obj-get-name caster)
 496                          " does not detect any traps")
 497            )
 498           (else
 499            (map (lambda (trap)
 500                   (trap-set-detected! trap #t)
 501                   (kern-log-msg (kern-obj-get-name caster)
 502                                 " detects a " (trap-name trap) " trap!")
 503                   )
 504                 traps)
 505            )))
 506   result-ok)
 507
 508 ;again, a bit of range for powerful users?
 509 (define (powers-dispel-field caster ktarg power)
 510    (kern-print "Dispelled field!\n")
 511    (kern-obj-remove ktarg)
 512    (kern-map-repaint)
 513    result-ok)
 514
 515 ;; todo saving throw vs caster power for different effects?
 516 (define (powers-dispel-magic caster ktarg power)
 517         (effects-dispel-magic ktarg)
 518         result-ok)
 519
 520 (define (powers-disarm-traps kchar ktarg power)
 521   (let (
 522         (traps (filter (lambda (trap)
 523                           (and (trap-detected? trap)
 524                                (not (trap-tripped? trap))))
 525                         (ifccall ktarg 'get-traps)))
 526         )
 527     ;; Check if any unprocessed traps remaining
 528     (cond ((null? traps)
 529            result-no-effect
 530            )
 531           ((not (handles? ktarg 'rm-traps))
 532            (kern-log-msg "Traps can't be removed!")
 533            result-no-effect
 534            )
 535           (else
 536            ;; Roll to succeed
 537            (let* (
 538                   (trap (car traps))
 539                   (dc (trap-avoid-dc trap))
 540                   (roll (kern-dice-roll "1d20"))
 541                   (bonus (kern-dice-roll (string-append "1d" (number->string power))))
 542                   )
 543              (cond ((or
 544                      (= roll 20)
 545                      (> (+ roll bonus) dc)
 546                      )
 547                     ;; Success - disarm the trap
 548                     (kern-log-msg (kern-obj-get-name kchar) " ^c+gdisarms^c- a " (trap-name trap) " trap!")
 549                     (trap-set-tripped! trap #t)
 550                     result-ok
 551                     )
 552                    (else
 553                     ;; Failure - trip the trap (kchar will get another roll
 554                     ;; to avoid the damage)
 555                     (trap-trigger trap ktarg kchar)
 556                     result-failed
 557                     )))))))
 558
 559
 560 ;todo limit range?
 561 (define (powers-fear caster unused power)
 562         (define (repel kchar)
 563                 (msg-log-visible (kern-obj-get-location kchar) (kern-obj-get-name kchar) " flees in terror!")
 564                 (kern-map-flash-sprite s_magicflash (loc-x tloc) (loc-y tloc))
 565                 (kern-char-set-fleeing kchar #t)
 566                 )
 567         (define (try-repel kchar)
 568                 (if (contest-of-skill
 569                                 (+ power 8)
 570                                 (occ-ability-magicdef kchar))
 571                         (repel kchar)))
 572         (map try-repel (all-hostiles caster))
 573         result-ok)
 574
 575 ;todo
 576 ; fields would be a lot more useful if a wall was created instead of one square
 577 ;   (length based on caster strength of course)
 578 ; I need a 'line' utility anyway, perhaps a ui along the lines of (select center point) (select end point)
 579 ;   -> draw line from centre to end and opposite side
 580 (define (powers-field-range power)
 581         (if (> power 30)
 582                 7
 583                 (+ 1 (/ power 5))
 584         ))
 585
 586 (define (powers-field-length power)
 587         (+ 1 (/ power 4)))
 588
 589 (define (powers-field-wall start stop f_type duration leng proc)
 590         (let ((lengremaining (list leng)))
 591                 (define (put-field location delta)
 592                         (powers-field-generic location f_type duration proc)
 593                         (set-car! lengremaining (- (car lengremaining) delta))
 594                         (> (car lengremaining) 0)
 595                         )
 596                 (line-draw (loc-place start) (loc-x start) (loc-y start) (loc-x stop) (loc-y stop) put-field)
 597         ))
 598
 599 (define (powers-field-fire-wall caster start stop power)
 600         (define (do-burn kobj)
 601                 (if (and (kern-obj-is-char? kobj)
 602                                 (not (has-fire-immunity? kobj)))
 603                         (kern-obj-inflict-damage kobj "burning" (kern-dice-roll "2d3+2") caster)
 604                 ))
 605         (powers-field-wall start stop F_fire (+ 20 (kern-dice-roll (mkdice 1 power))) (powers-field-length power) do-burn)
 606         result-ok)
 607
 608 (define (powers-field-energy-wall caster start stop power)
 609         (define (do-burn kobj)
 610                 (if (kern-obj-is-char? kobj)
 611                         (kern-obj-inflict-damage kobj "shocked" (kern-dice-roll "2d8") caster)
 612                 ))
 613         (powers-field-wall start stop F_energy (+ 20 (kern-dice-roll (mkdice 2 power))) (powers-field-length power) do-burn)
 614         result-ok)
 615
 616 (define (powers-field-poison-wall caster start stop power)
 617         (define (do-burn kobj)
 618                 (if (and (kern-obj-is-char? kobj)
 619                                 (not (has-poison-immunity? kobj)))
 620                         (begin
 621                                 (apply-poison kobj)
 622                                 (kern-harm-relations kobj caster)
 623                                 (kern-harm-relations kobj caster)
 624                         )
 625                 ))
 626         (powers-field-wall start stop F_poison (+ 10 (kern-dice-roll (mkdice 1 power))) (powers-field-length power) do-burn)
 627         result-ok)
 628
 629 (define (powers-field-sleep-wall caster start stop power)
 630         (define (do-burn kobj)
 631                 (if (and (kern-obj-is-char? kobj)
 632                                 (not (has-sleep-immunity? kobj)))
 633                         (begin
 634                                 (kern-harm-relations kobj caster)
 635                                 (apply-sleep kobj)
 636                         )
 637                 ))
 638         (powers-field-wall start stop F_sleep (+ 15 (kern-dice-roll (mkdice 1 power))) (powers-field-length power) do-burn)
 639         result-ok)
 640
 641 (define (powers-field-energy caster ktarg power)
 642         (kern-obj-put-at (kern-mk-field F_energy (+ 20 (kern-dice-roll (mkdice 2 power)))) ktarg)
 643         result-ok)
 644
 645 (define (powers-field-fire caster ktarg power)
 646         (kern-obj-put-at (kern-mk-field F_fire (+ 20 (kern-dice-roll (mkdice 1 power)))) ktarg)
 647         result-ok)
 648
 649 (define (powers-field-poison caster ktarg power)
 650         (kern-obj-put-at (kern-mk-field F_poison (+ 10 (kern-dice-roll (mkdice 1 power)))) ktarg)
 651         result-ok)
 652
 653 (define (powers-field-sleep caster ktarg power)
 654         (kern-obj-put-at (kern-mk-field F_sleep (+ 15 (kern-dice-roll (mkdice 1 power)))) ktarg)
 655         result-ok)
 656
 657 (define (powers-field-energy-weak caster ktarg power)
 658         (powers-field-generic ktarg F_energy (+ 5 (kern-dice-roll (mkdice 1 (ceiling (/ power 2))))) apply-lightning)
 659         result-ok)
 660
 661 (define (powers-field-fire-weak caster ktarg power)
 662         (powers-field-generic ktarg F_fire (+ 5 (kern-dice-roll (mkdice 1 (ceiling (/ power 3))))) burn)
 663         result-ok)
 664
 665 (define (powers-field-poison-weak caster ktarg power)
 666         (powers-field-generic ktarg F_poison (+ 3 (kern-dice-roll (mkdice 1 (ceiling (/ power 3))))) apply-poison)
 667         result-ok)
 668
 669 (define (powers-field-sleep-weak caster ktarg power)
 670         (powers-field-generic ktarg F_sleep (+ 4 (kern-dice-roll (mkdice 1 (ceiling (/ power 3))))) apply-sleep)
 671         result-ok)
 672
 673 (define (powers-fireball-range power)
 674         (+ 3 (/ power 3)))
 675
 676 ;; returns true if the location is ok
 677 (define (powers-fireball-collateral-check caster targloc apower)
 678         ;;(println "fireball check")
 679         (let ((place (loc-place targloc))
 680                         (x (loc-x targloc))
 681                         (y (loc-y targloc)))
 682                 (define (checkloc kloc)
 683                         (null?
 684                                 (filter
 685                                         (lambda (kobj)
 686                                                 (and (kern-obj-is-char? kobj)
 687                                                         (not (is-hostile? kobj caster))
 688                                                         )
 689                                         )
 690                                         (kern-get-objects-at kloc)
 691                                 )
 692                         ))
 693                 (define (checkoff xoff yoff)
 694                         (let ((kloc (mk-loc place (+ x xoff) (+ y yoff))))
 695                                 (if (kern-is-valid-location? kloc)
 696                                         (checkloc kloc)
 697                                         #t
 698                                 )
 699                         ))
 700                 (and (checkoff 0 0)
 701                         (or (<= apower 10)
 702                                 (and (checkoff 1 0)
 703                                         (checkoff -1 0)
 704                                         (checkoff 0 1)
 705                                         (checkoff 0 -1)
 706                                 ))
 707                         (or (<= apower 15)
 708                                 (and (checkoff 1 1)
 709                                         (checkoff 1 -1)
 710                                         (checkoff -1 1)
 711                                         (checkoff -1 -1)
 712                                 ))
 713                         )
 714         ))
 715
 716 (define (powers-fireball caster ktarg apower)
 717         ;;(println "fireball")
 718         (define (fireball-damage-dice power)
 719                 (if (> power 3) (string-append (number->string  (floor (/ power 2))) "d3")
 720                                 "1d3"))
 721         (define (is-my-field? kobj) (eqv? F_fire (kern-obj-get-type kobj)))
 722         (define (cleanfields kplace x y)
 723                 (let ((kloc (mk-loc kplace x y)))
 724                         (if (kern-is-valid-location? kloc)
 725                                 (let ((fields (filter is-my-field? (kern-get-objects-at kloc))))
 726                                         (cond ((null? fields) nil)
 727                                                 (else
 728                                                         (kern-obj-remove (car fields))))))))
 729         (define (do-fireball-hit kplace x y damdf damdi)
 730           (define (fire-damage kobj)
 731             (if (kern-obj-is-char? kobj)
 732                 (begin
 733                   (kern-log-msg "Burning!")
 734                   (if (not (has-fire-immunity? kobj))
 735                       (kern-obj-inflict-damage kobj "burning" (kern-dice-roll damdf) caster)
 736                                  (if (not (null? damdi))
 737                         (kern-obj-inflict-damage kobj "impact" (kern-dice-roll damdi) caster))
 738                         ))
 739                 ;;(kern-obj-apply-damage kobj "burning" (kern-dice-roll damdf))
 740                 ))
 741           (let ((kloc (mk-loc kplace x y)))
 742             (if (kern-is-valid-location? kloc)
 743                 (begin
 744                   (kern-obj-put-at (kern-mk-obj F_fire 1) kloc)
 745                   (kern-map-repaint)
 746                   (for-each fire-damage
 747                             (kern-get-objects-at kloc))
 748                   ))))
 749         (let* ((targchar (get-being-at ktarg))
 750                 (damf (fireball-damage-dice apower))
 751                 (dami (if (> apower 5) (fireball-damage-dice (/ apower 3)) nil)))
 752                 (define (do-fireball-effect kplace x y)
 753                         (kern-sound-play-at sound-explode (mk-loc kplace x y))
 754                         (do-fireball-hit kplace x y damf dami)
 755                         (if (> apower 10) (let ((apower (- apower 5))
 756                                         (damf (fireball-damage-dice apower))
 757                                         (dami (if (> apower 5) (fireball-damage-dice (/ apower 3)) nil)))
 758                                 (do-fireball-hit kplace (+ x 1) y damf dami)
 759                                 (do-fireball-hit kplace (- x 1) y damf dami)
 760                                 (do-fireball-hit kplace x (+ y 1) damf dami)
 761                                 (do-fireball-hit kplace x (- y 1) damf dami)
 762                         (if (> apower 10) (let ((apower (- apower 5))
 763                                         (damf (fireball-damage-dice apower))
 764                                         (dami (if (> apower 5) (fireball-damage-dice (/ apower 3)) nil)))
 765                                 (do-fireball-hit kplace (+ x 1) (+ y 1) damf dami)
 766                                 (do-fireball-hit kplace (- x 1) (+ y 1) damf dami)
 767                                 (do-fireball-hit kplace (+ x 1) (- y 1) damf dami)
 768                                 (do-fireball-hit kplace (- x 1) (- y 1) damf dami)
 769                                 (cleanfields kplace (+ x 1) (+ y 1))
 770                                 (cleanfields kplace (- x 1) (+ y 1))
 771                                 (cleanfields kplace (+ x 1) (- y 1))
 772                                 (cleanfields kplace (- x 1) (- y 1))
 773                         ))
 774                         (cleanfields kplace (+ x 1) y)
 775                         (cleanfields kplace (- x 1) y)
 776                         (cleanfields kplace x (+ y 1))
 777                         (cleanfields kplace x (- y 1))
 778                         ))
 779                         (cleanfields kplace x y)
 780                 )
 781                 (if (null? targchar)
 782                         (kern-log-msg (kern-obj-get-name caster)
 783                                                         " hurls a fireball")
 784                         (kern-log-msg (kern-obj-get-name caster)
 785                                                         " hurls a fireball at "
 786                                                 (kern-obj-get-name targchar)))
 787                 (temp-ifc-set
 788                         (lambda (kmissile kuser ktarget kplace x y)
 789                                 (do-fireball-effect kplace x y)
 790                         )
 791                 )
 792                 (kern-sound-play-at sound-missile (kern-obj-get-location caster))
 793                 (kern-sound-play-at sound-missile ktarg)
 794                 (kern-fire-missile t_mfireball
 795                      (kern-obj-get-location caster)
 796                      ktarg))
 797         result-ok)
 798
 799 ;todo high power should go to user specified gate
 800 (define (powers-gate-travel caster ktarg power)
 801   ;; Fix for bug 1738251, which involved summoning gates over magically locked
 802   ;; doors: check passability. Use the passability of the caster as a
 803   ;; reasonable estimate for the passability of the gate.
 804   (if (not (kern-place-is-passable ktarg caster))
 805       result-not-here
 806       (let ((gate (summon-moongate 'ord)))
 807         (kern-obj-put-at gate ktarg)
 808         (moongate-open gate)
 809         result-ok)))
 810
 811 (define (powers-great-light caster ktarg power)
 812         (let ((lightadd
 813                         (kern-dice-roll
 814                                 (mkdice 5 power))))
 815                 (light-apply-new ktarg (+ 6000 (* 50 power))))
 816                 result-ok)
 817
 818 ;todo should the messages be in the ui part?
 819 (define (powers-great-heal kchar ktarg power)
 820   (kern-log-msg (kern-obj-get-name kchar)
 821                 " casts a great healing spell on "
 822                 (if (eqv? kchar ktarg)
 823                     "self"
 824                     (kern-obj-get-name ktarg)))
 825   (kern-obj-heal ktarg
 826                  (+ 10 power (kern-dice-roll "2d20")
 827                     (kern-dice-roll (mkdice 4 power))))
 828   result-ok)
 829
 830 ;todo should the messages be in the ui part?
 831 (define (powers-heal kchar ktarg power)
 832   (kern-log-msg (kern-obj-get-name kchar)
 833                 " casts a healing spell on "
 834                 (if (eqv? kchar ktarg)
 835                     "self"
 836                     (kern-obj-get-name ktarg)))
 837   (kern-obj-heal ktarg
 838                  (+ 2 (kern-dice-roll "1d10")
 839                     (kern-dice-roll (mkdice 2 power))))
 840   result-ok)
 841
 842 ;todo vary duration with power
 843 (define (powers-invisibility kchar ktarg power)
 844         (kern-obj-add-effect ktarg ef_invisibility nil)
 845         result-ok)
 846
 847 ;todo hack in something for xp & hostility
 848 (define (powers-kill kchar ktarg)
 849   (kern-log-msg (kern-obj-get-name kchar)
 850                 " casts kill at "
 851                 (kern-obj-get-name ktarg))
 852         (kern-sound-play-at sound-missile (kern-obj-get-location kchar))
 853         (kern-sound-play-at sound-missile (kern-obj-get-location ktarg))
 854   (cast-missile-proc kchar ktarg t_deathball)
 855   result-ok)
 856
 857 (define (powers-light caster ktarg power)
 858         (let ((lightadd
 859                         (kern-dice-roll
 860                                 (mkdice 5 power))))
 861                 (light-apply-new ktarg (+ 400 (* 5 power))))
 862                 result-ok)
 863
 864 (define (powers-lightning-range power)
 865         (+ 3 (/ power 2.5)))
 866
 867 ;; todo will fail on looping maps
 868 (define (powers-lightning-collateral-check caster targloc apower)
 869         ;;(println "checkzap")
 870         (let* ((range (powers-lightning-range apower))
 871                         (casterloc (kern-obj-get-location caster))
 872                         (targrange (+ 1 (kern-get-distance targloc casterloc)))
 873                         (rangemult (if (> targrange 0) (ceiling (/ range targrange)) 0))
 874                         (dx (* rangemult (- (loc-x targloc) (loc-x casterloc))))
 875                         (dy (* rangemult (- (loc-y targloc) (loc-y casterloc))))
 876                         (endx (+ (loc-x casterloc) dx))
 877                         (endy (+ (loc-y casterloc) dy))
 878                         (shot-ok (list #t))
 879                         (range-ok (> range targrange))
 880                         )
 881                 (define (check-loc location delta)
 882                         (cond ((equal? location casterloc) #t)
 883                                 ((> (kern-get-distance location casterloc) range) #f)
 884                                 ((null? (filter
 885                                                         (lambda (kobj)
 886                                                                 (and (kern-obj-is-char? kobj)
 887                                                                         (not (is-hostile? kobj caster))
 888                                                                         )
 889                                                         )
 890                                                         (kern-get-objects-at location)
 891                                                 ))
 892                                         #t
 893                                         )
 894                                 (else (set-car! shot-ok #f) #f)
 895                         ))
 896                 (if (and range-ok (> rangemult 0))
 897                         (begin
 898                                 (line-draw (loc-place targloc) (loc-x casterloc) (loc-y casterloc) endx endy check-loc)
 899                                 (car shot-ok)
 900                         )
 901                         #f
 902                 )
 903         ))
 904
 905 (define (powers-lightning caster targloc apower)
 906         ;;(println "zap")
 907   (let ((targets (list nil))
 908         (dam (mkdice (floor (+ 1 (/ apower 3))) 4))
 909         )
 910     (temp-ifc-set
 911      (lambda (kmissile kuser ktarget kplace x y unused)
 912        (let (
 913              (targchar (get-being-at (mk-loc kplace x y)))
 914              )
 915          (if (not (null? targchar))
 916              (set-car! targets (cons targchar (car targets)))
 917              ))
 918        #t
 919        ))
 920     (kern-sound-play sound-lightning)
 921     (kern-fire-missile-to-max t_lightning_bolt (powers-lightning-range apower)
 922                               (kern-obj-get-location caster)
 923                               targloc
 924                               )
 925     (if (not (null? (car targets)))
 926         (map
 927          (lambda (zappee)
 928            (kern-log-msg (kern-obj-get-name zappee) " shocked!")
 929            (kern-obj-inflict-damage zappee "shocked" (kern-dice-roll dam) caster)
 930            )
 931          (car targets)
 932          ))
 933     )
 934   result-ok)
 935
 936 (define (powers-lock caster ktarg power)
 937         ((kobj-ifc ktarg) 'lock ktarg caster)
 938         result-ok)
 939
 940 (define (powers-lock-magic caster ktarg power)
 941         ((kobj-ifc ktarg) 'magic-lock ktarg caster)
 942         result-ok)
 943
 944 (define (powers-locate caster ktarg power)
 945         (let ((loc (kern-obj-get-location caster)))
 946                 (kern-log-msg "You are in " (kern-place-get-name (car loc))
 947                               " at [x=" (cadr loc) " y=" (caddr loc) "]"))
 948         result-ok)
 949
 950 (define (powers-magic-missile-range power)
 951         (+ 4 (/ power 3)))
 952
 953 ;todo messages out?
 954 (define (powers-magic-missile kchar ktarg power)
 955         (kern-sound-play-at sound-missile (kern-obj-get-location kchar))
 956         (kern-sound-play-at sound-missile (kern-obj-get-location ktarg))
 957         (kern-log-msg (kern-obj-get-name kchar)
 958                         " fires magic missile at "
 959                         (kern-obj-get-name ktarg))
 960         (if (cast-missile-proc kchar ktarg t_magicarrow_p)
 961                 (let* (
 962                         (apower
 963                                 (ceiling (-
 964                                         (/ power 2)
 965                                         (/ (occ-ability-magicdef ktarg) 10)
 966                                         )))
 967                         (damagedice (string-append
 968                                 (number->string (if (> apower 0) apower 1))
 969                                 "d3")))
 970                 (kern-obj-inflict-damage ktarg
 971                                                          "magic" (kern-dice-roll damagedice) kchar)))
 972         result-ok)
 973
 974 (define (powers-negate-magic caster ktarg power)
 975         (kern-add-magic-negated (kern-dice-roll
 976                 (mkdice 3 (floor (+ (/ power 3) 1)))))
 977         result-ok)
 978
 979 (define (powers-paralyse caster ktarg power)
 980         (if (and (can-paralyze? ktarg)
 981                                 (contest-of-skill
 982                                                 (+ power 5)
 983                                                 (occ-ability-magicdef ktarg)))
 984         (kern-obj-add-effect ktarg ef_paralyze nil))
 985         result-ok)
 986
 987 (define (powers-poison-range power)
 988         (+ 3 (/ power 3)))
 989
 990 ;todo contest to resist? to-hit roll required? power based initial damage?
 991 ;note instant hostility - you cant just cause someone to slowly die and say
 992 ;sorry afterwards
 993 (define (powers-poison-effect caster ktarg power)
 994         (if (and (kern-obj-is-char? ktarg)
 995                         (not (null? ktarg)))
 996                 (begin
 997                   (if (contest-of-skill
 998                        power
 999                        (occ-ability-dexdefend ktarg))
1000                       (apply-poison ktarg)
1001                       (kern-log-msg (kern-obj-get-name ktarg) " avoids poison!")
1002                 )))
1003         )
1004
1005 (define (powers-poison caster ktarg power)
1006         (define (do-poison-effect kmissile kuser ktarget kplace x y dam)
1007                 (on-hit-target ktarget dam
1008                                         (lambda (obj) (powers-poison-effect kuser obj (+ power 10))))
1009                 (on-hit-nontarget ktarget (loc-mk kplace x y) dam
1010                                         (lambda (obj) (powers-poison-effect kuser obj power)))
1011                                 )
1012         (temp-ifc-set do-poison-effect)
1013         (kern-log-msg (kern-obj-get-name caster)
1014                                 " hurls poison missile at "
1015                                 (kern-obj-get-name ktarg))
1016         (kern-harm-relations ktarg caster)
1017         (kern-harm-relations ktarg caster)
1018         (kern-harm-relations ktarg caster)
1019         (kern-harm-relations ktarg caster)
1020         (kern-sound-play-at sound-missile (kern-obj-get-location caster))
1021         (kern-sound-play-at sound-missile (kern-obj-get-location ktarg))
1022         (cast-missile-proc caster ktarg t_mpoison_bolt)
1023         result-ok)
1024
1025 ;todo duration based on power?
1026 (define (powers-protect caster ktarg power)
1027   (let ((party (kern-char-get-party caster)))
1028     (if (null? party)
1029         (kern-obj-add-effect caster ef_protection nil)
1030         (kern-obj-add-effect party ef_protection nil)
1031         )
1032     )
1033         result-ok)
1034
1035 ;todo duration based on power?
1036 (define (powers-protect-vs-fire caster ktarg power)
1037         (kern-obj-add-effect ktarg ef_temporary_fire_immunity nil)
1038         result-ok)
1039
1040 ;todo duration based on power?
1041 (define (powers-protect-vs-poison caster ktarg power)
1042         (kern-obj-add-effect ktarg ef_temporary_poison_immunity nil)
1043         result-ok)
1044
1045 ;todo duration based on power?
1046 (define (powers-protect-vs-poison-all caster ktarg power)
1047   (let ((party (kern-char-get-party caster)))
1048     (if (null? party)
1049         (kern-obj-add-effect caster ef_temporary_poison_immunity nil)
1050         (kern-obj-add-effect party ef_temporary_poison_immunity nil)
1051         )
1052     )
1053         result-ok)
1054
1055 (define (powers-quickness caster dir power)
1056         (kern-add-quicken (kern-dice-roll
1057                 (mkdice 3 (floor (+ (/ power 3) 1)))))
1058         result-ok)
1059
1060 ;note is different scenarios, could have other uses
1061 (define (powers-raise-lost-area caster loc power)
1062         (let ((kobjs (filter can-raise-vessel?
1063                                         (kern-get-objects-at loc))))
1064                 (if (not (null? kobjs))
1065                         (let ((kgen (car kobjs)))
1066                                 (signal-kobj kgen 'raise kgen caster)
1067                         )))
1068         result-ok)
1069
1070 ;resurrect should have side effects, diminishing with power
1071 (define (powers-resurrect caster ktarg power)
1072   (cond ((is-dead? ktarg)
1073          (kern-char-resurrect ktarg)
1074          (apply-sleep ktarg)
1075          result-ok)
1076         (else
1077          result-no-effect))
1078         result-ok)
1079
1080 (define (powers-reveal caster ktarg power)
1081         (kern-add-reveal (* power 4))
1082         result-ok)
1083
1084
1085 (define (powers-sleep-target-range power)
1086         (+ (/ power 3) 3))
1087
1088 (define (powers-sleep-apply target power)
1089         (if (contest-of-skill power (occ-ability-magicdef target))
1090                         (begin
1091                                 (msg-log-visible (kern-obj-get-location target) (kern-obj-get-name target) " slept")
1092                                 (apply-sleep target))
1093                         (begin
1094                                 (msg-log-visible (kern-obj-get-location target) (kern-obj-get-name target) " resists sleep"))
1095         ))
1096
1097 (define (powers-sleep-target caster ktarg power)
1098         (powers-sleep-apply ktarg (+ power 6))
1099         (kern-harm-relations ktarg caster)
1100   result-ok)
1101
1102 ;todo limit to some range?
1103 (define (powers-sleep-area caster ktarg power)
1104         (let ((hostiles (all-hostiles caster)))
1105                 (define (trysleep target)
1106                         (powers-sleep-apply target (+ power 3))
1107                         )
1108        (cond ((null? hostiles) result-ok)
1109              (else
1110               (map trysleep hostiles)
1111               result-ok))))
1112
1113 (define (powers-smoke-range power)
1114         (+ 3 (/ power 3)))
1115
1116 (define (powers-smoke-field caster ktarg apower)
1117         (fields-smoke-apply (loc-place ktarg) (loc-x ktarg) (loc-y ktarg) apower)
1118         result-ok
1119         )
1120
1121 ;todo duration based on power?
1122 (define (powers-spider-calm caster ktarg power)
1123         (kern-obj-add-effect ktarg ef_spider_calm nil)
1124         result-ok)
1125
1126 (define (powers-summon targetloc quantity typegen levelgen faction)
1127         (define (run-loop count done)
1128                 (if (<= count 0) done
1129                         (let* ((knpc (spawn-npc (typegen) (levelgen)))
1130                                         (loc (pick-loc targetloc knpc)))
1131                                 (if (null? loc)
1132                                         (begin
1133                                                 (kern-obj-dec-ref knpc)
1134                                                 done)
1135                                         (begin
1136                                                 (kern-being-set-base-faction knpc faction)
1137                                                 (kern-obj-set-temporary knpc #t)
1138                                                 (kern-obj-put-at knpc loc)
1139                                                 (run-loop (- count 1) 1)
1140                                         )))))
1141         (run-loop quantity 0))
1142
1143 (define (powers-summon-simple-levelgen power)
1144         (lambda ()
1145                 (+ (floor (+ (* power 0.2) 1
1146                         (kern-dice-roll
1147                                 (mkdice 3 (floor (+ (* power 0.2) 1))))
1148                         )))))
1149
1150 (define (powers-summon-single-type type)
1151         (lambda ()
1152                 type
1153         ))
1154
1155 ;todo enable remote summoning for high power?
1156 (define (powers-summon-medium-size caster ktarg power type-tag)
1157   (let ((spower (floor (+ (/ power 4) 1))))
1158         (powers-summon (kern-obj-get-location caster)
1159                         (kern-dice-roll (mkdice 1 spower))
1160                         (powers-summon-single-type type-tag)
1161                         (powers-summon-simple-levelgen power)
1162                         (kern-being-get-base-faction caster))
1163         ))
1164
1165 ;todo enable remote summoning for high power?
1166 (define (powers-summon-snake caster ktarg power)
1167   (powers-summon-medium-size caster ktarg power 'snake)
1168         result-ok)
1169
1170 ;todo enable remote summoning for high power?
1171 (define (powers-summon-spider caster ktarg power)
1172   (powers-summon-medium-size caster ktarg power 'giant-spider)
1173         result-ok)
1174
1175 ;todo enable remote summoning for high power?
1176 (define (powers-summon-wolf caster ktarg power)
1177   (powers-summon-medium-size caster ktarg power 'wolf)
1178         result-ok)
1179
1180 ;todo enable remote summoning for high power?
1181 (define (powers-summon-small caster ktarg power type-tag)
1182   (let ((spower (floor (+ (/ power 4) 1))))
1183         (powers-summon (kern-obj-get-location caster)
1184                         (kern-dice-roll (mkdice 2 spower))
1185                         (powers-summon-single-type type-tag)
1186                         (powers-summon-simple-levelgen power)
1187                         (kern-being-get-base-faction caster))
1188         ))
1189
1190 ;todo enable remote summoning for high power?
1191 (define (powers-summon-insect caster ktarg power)
1192   (powers-summon-small caster ktarg power 'insect)
1193         result-ok)
1194
1195 ;todo enable remote summoning for high power?
1196 (define (powers-summon-rat caster ktarg power)
1197   (powers-summon-small caster ktarg power 'rat)
1198         result-ok)
1199
1200 ;todo enable remote summoning for high power?
1201 (define (powers-summon-bat caster ktarg power)
1202   (powers-summon-small caster ktarg power 'bat)
1203         result-ok)
1204
1205 ;todo enable remote summoning for high power?
1206 (define (powers-summon-undead caster ktarg power)
1207   (let ((spower (floor (+ (/ power 4) 1))))
1208         (powers-summon (kern-obj-get-location caster)
1209                         (kern-dice-roll (mkdice 1 spower))
1210                         (lambda ()
1211                 (random-select (list 'skeletal-warrior 'skeletal-spear-thrower 'ghast)))
1212                         (powers-summon-simple-levelgen power)
1213                         (kern-being-get-base-faction caster))
1214         )
1215         result-ok)
1216
1217 (define (powers-summon-slime caster ktarg power)
1218   (let ((spower (floor (+ (/ power 4) 1))))
1219         (powers-summon (kern-obj-get-location caster)
1220                         (kern-dice-roll (mkdice 1 spower))
1221                         (powers-summon-single-type 'green-slime)
1222                         (powers-summon-simple-levelgen power)
1223                         (kern-being-get-base-faction caster))
1224         )
1225         result-ok)
1226
1227
1228 (define (powers-telekinesis-range power)
1229         (+ (/ power 3) 1))
1230
1231 ;todo damage/knock away critters?
1232 ;should fail on no handler squares rather than aborting?
1233 (define (powers-telekinesis caster ktarg power)
1234   ((kobj-ifc ktarg) 'handle ktarg caster)
1235   result-ok)
1236
1237 (define (powers-timestop caster dir power)
1238         (kern-add-time-stop (kern-dice-roll
1239                 (mkdice 3 (floor (+ (/ power 3) 1)))))
1240         result-ok)
1241
1242 ; a few things needed here:
1243 ;       check for visibility before messages
1244 ;       no player specific messages
1245 ;       only hits hostiles
1246 ;   area of effect based on power
1247 ;       'turned' as an effect? [so it shows on description] or maybe fleeing should show...
1248 (define (powers-turn-undead caster unused power)
1249         (define (is-undead-char? kobj)
1250                 (and (obj-is-char? kobj)
1251                 (species-is-undead? (kern-char-get-species kobj)))
1252                 )
1253         (define (repel kchar)
1254                 (if (contest-of-skill
1255                                 (+ power 3)
1256                                 (occ-ability-magicdef kchar))
1257                         (let ((tloc (kern-obj-get-location kchar)))
1258                                 (kern-map-flash-sprite s_magicflash (loc-x tloc) (loc-y tloc))
1259                                 (msg-log-visible tloc (kern-obj-get-name kchar) " turned")
1260                                 (kern-char-set-fleeing kchar #t)
1261                         )
1262                         (begin
1263                                 (msg-log-visible (kern-obj-get-location kchar) (kern-obj-get-name kchar) " resists")
1264                         )
1265                 )
1266         )
1267         (let* ((all-kobjs (all-hostiles caster))
1268                 (all-undead-combatants (filter is-undead-char? all-kobjs)))
1269                         (map repel all-undead-combatants)
1270         )
1271         result-ok)
1272
1273 ;todo limit to some (large) range?
1274 (define (powers-tremor caster unused power)
1275         (let ((damdice (mkdice 1 power))
1276                 (foes (all-hostiles caster)))
1277         (define (tremor kchar)
1278                 (cond ((kern-char-is-asleep? kchar) (kern-char-set-sleep kchar #f))
1279                         ((> (kern-dice-roll "1d4") 1)
1280                                 (kern-map-set-jitter #t)
1281                                 (kern-map-repaint)
1282                                 (kern-char-set-sleep kchar #t)
1283                                 (kern-obj-inflict-damage kchar "knocked down" (kern-dice-roll damdice) caster))
1284                                 (else nil)))
1285         (define (loop n kchar)
1286                 (if (not (= n 0))
1287                         (begin
1288                         (map tremor kchar)
1289                         (loop (- n 1) kchar))))
1290         (define (wakeup kchar) (kern-char-set-sleep kchar #f))
1291     (kern-log-enable #f)
1292     (map kern-obj-inc-ref foes)
1293     (shake-map 20)
1294     (loop (+ 1 (floor (/ power 4))) foes)
1295     (kern-map-repaint)
1296     (map wakeup foes)
1297     (map kern-obj-dec-ref foes)
1298     (map wakeup (kern-place-get-beings (loc-place (kern-obj-get-location caster))))
1299         (kern-log-enable #t)
1300         )
1301         result-ok)
1302
1303 (define (powers-unlock caster ktarg power)
1304   (println "power:" power)
1305   (let ((dc ((kobj-ifc ktarg) 'get-unlock-dc ktarg caster)))
1306     (println "dc:" dc)
1307     (if (= 0 dc)
1308         result-no-effect
1309         (let ((roll (kern-dice-roll "1d20"))
1310               (bonus (kern-dice-roll (string-append "1d" (number->string power)))))
1311           (println "roll:" roll)
1312           (println "bonus:" bonus)
1313           (cond ((or (= roll 20)
1314                      (> (+ roll bonus ) dc))
1315                  (if ((kobj-ifc ktarg) 'unlock ktarg caster)
1316                      result-ok
1317                      result-no-effect))
1318                 (else result-failed))))))
1319
1320 (define (powers-unlock-magic caster ktarg power)
1321   (if ((kobj-ifc ktarg) 'magic-unlock ktarg caster)
1322       result-ok
1323       result-no-effect))
1324
1325 (define (powers-view caster ktarg power)
1326         (kern-map-center-camera (kern-obj-get-location caster))
1327         (kern-map-set-peering #t)
1328         (kern-map-repaint)
1329         (kern-print "Hit a key when done gazing...\n")
1330         (ui-waitkey)
1331         (kern-map-set-peering #f)
1332         (kern-map-repaint)
1333         result-ok)
1334
1335 (define (powers-web-range power)
1336         (+ 3 (/ power 3)))
1337
1338 ;note defense is dodge, not magicdef
1339 (define (powers-web caster target power)
1340         (define (do-web-effect kplace x y)
1341                 (let* ((loc (mk-loc kplace x y))
1342                                 (targchar (get-being-at loc)))
1343                         (if (not (null? targchar))
1344                                 (begin
1345                                         (if (contest-of-skill
1346                                                         power
1347                                                         (occ-ability-dexdefend targchar))
1348                                                 (ensnare targchar))
1349                                                 (kern-harm-relations kobj caster)))
1350                         (if (and (< (kern-dice-roll "1d20") power)
1351                                         (terrain-ok-for-field? loc))
1352                                 (kern-obj-put-at (kern-mk-obj web-type 1) loc))
1353                 ))
1354         (let ((targchar (get-being-at target)))
1355                 (if (null? targchar)
1356                         (kern-log-msg (kern-obj-get-name caster)
1357                                                         " hurls a web")
1358                         (kern-log-msg (kern-obj-get-name caster)
1359                                                         " hurls a web at "
1360                                                 (kern-obj-get-name targchar)))
1361                 (temp-ifc-set
1362                         (lambda (kmissile kplace x y)
1363                                 (do-web-effect kplace x y)
1364                         ))
1365                 (kern-sound-play-at sound-missile (kern-obj-get-location caster))
1366                 (kern-sound-play-at sound-missile target)
1367                 (kern-fire-missile t_mweb
1368                      (kern-obj-get-location caster)
1369                      target)
1370         )
1371         result-ok)
1372
1373 (define (powers-wind-change caster dir power)
1374         (kern-set-wind dir (+ 10 (kern-dice-roll (mkdice (* 2 power) 6))))
1375         result-ok)
1376
1377 (define (powers-xray caster dir power)
1378         (kern-add-xray-vision (kern-dice-roll
1379                 (mkdice 10 (floor (+ (/ power 3) 1)))))
1380         result-ok)
1381
1382 ;; vttjo - "Vectors to tiles jumped over"
1383 (define (powers-jump-vttjo dx dy)
1384     (cond ((= dx 2)
1385            (cond ((= dy -1) (list (cons 1 0) (cons 1 -1)))
1386                  ((= dy 0)  (list (cons 1 0)))
1387                  ((= dy 1)  (list (cons 1 0) (cons 1 1)))
1388                  (else nil)))
1389           ((= dx 1)
1390            (cond ((= dy -2) (list (cons 0 -1) (cons 1 -1)))
1391                  ((= dy 2)  (list (cons 0 1) (cons 1 1)))
1392                  (else nil)))
1393           ((= dx 0)
1394            (cond ((= dy -2) (list (cons 0 -1)))
1395                  ((= dy 2) (list (cons 0 1)))
1396                  (else nil)))
1397           ((= dx -1)
1398            (cond ((= dy -2) (list (cons 0 -1) (cons -1 -1)))
1399                  ((= dy 2) (list (cons 0 1) (cons -1 1)))
1400                  (else nil)))
1401           ((= dx -2)
1402            (cond ((= dy -1) (list (cons -1 0) (cons -1 -1)))
1403                  ((= dy 0)  (list (cons -1 0)))
1404                  ((= dy 1)  (list (cons -1 0) (cons -1 1)))
1405                  (else nil)))
1406           (else nil)))
1407
1408 (define (powers-jump caster ktarg power)
1409   (let ((cloc (kern-obj-get-location caster)))
1410
1411     ;; special case: when jumping 1 (or fewer tiles) use normal movement mode
1412     (define (jump-one)
1413       (cond ((not (kern-place-move-is-passable? cloc ktarg caster))
1414              (kern-log-msg "Jump failed: blocked!")
1415              result-no-effect)
1416             (else
1417              (kern-obj-relocate caster ktarg nil)
1418              result-ok)))
1419
1420     (cond ((not (kern-place-is-passable ktarg caster))
1421            (kern-log-msg "Jump Failed: Impassable terrain")
1422            result-no-effect)
1423           (else
1424            (let* ((vect (loc-diff cloc ktarg))
1425                   (dx (loc-x vect))
1426                   (dy (loc-y vect))
1427                   (kplace (loc-place (kern-obj-get-location caster))))
1428              (cond ((and (<= (abs dx) 1) (<= (abs dy) 1))
1429                     (jump-one))
1430                    (else
1431                     ;; normal case: jump of more than 1 tile
1432                     (kern-obj-set-mmode caster mmode-jump)
1433                     (let* ((vttjo (powers-jump-vttjo dx dy))
1434                           (result
1435                            (cond ((foldr (lambda (val vtt)
1436                                            (or val
1437                                                (not (kern-place-is-passable
1438                                                      (mk-loc kplace
1439                                                              (+ (car vtt) (loc-x cloc))
1440                                                              (+ (cdr vtt) (loc-y cloc)))
1441                                                      caster))))
1442                                          #f vttjo)
1443                                   (kern-log-msg "Jump failed: blocked!")
1444                                   result-no-effect)
1445                                  (else
1446                                   (kern-obj-relocate caster ktarg nil)
1447                                   (kern-obj-add-effect caster ef_fatigue nil)
1448                                   result-ok))))
1449                       (kern-obj-set-mmode caster nil)
1450                       result))))))))
1451
1452 (define (powers-sprint caster ktarg power)
1453   ;; hokay... first let's get the path from here to there
1454   (let* ((origin (kern-obj-get-location caster))
1455          (kplace (loc-place origin))
1456          (path (line (loc-x origin) (loc-y origin)
1457                      (loc-x ktarg) (loc-y ktarg)))
1458          )
1459     ;; and now, for each point on the path, let's move the dude there and apply
1460     ;; any terrain/field effects. The way should be passable (unless we do
1461     ;; something weird like along the way trigger a mech which throws up a
1462     ;; wall, in which case I guess that's an advantage of having the sprint
1463     ;; skill ;) Note that the dude may die along the way due to tile effects,
1464     ;; so keep a ref count just to be safe and check for death in the move-dude
1465     ;; function.
1466     (define (move-dude ok xy)
1467       (and ok
1468            (let ((loc (loc-mk kplace (car xy) (cdr xy))))
1469              (cond ((or (not (passable? loc caster))
1470                         (occupied? loc))
1471                     (println loc " impassable")
1472                     #f
1473                     )
1474                    ((not (kern-char-is-dead? caster))
1475                     (kern-obj-relocate caster loc nil)
1476                     (kern-map-repaint)
1477                     (kern-place-apply-tile-effects kplace caster)
1478                     #t
1479                     )
1480                    ))))
1481     (kern-obj-inc-ref caster)
1482     (foldr move-dude #t (cdr path))
1483     (kern-obj-dec-ref caster)
1484     )
1485   (kern-obj-add-effect caster ef_fatigue nil)
1486   result-ok)
1487
1488 ;; Roll to even make the attempt, then roll to see if you get stuck.
1489 (define (powers-wriggle caster ktarg power)
1490   (kern-obj-set-mmode caster mmode-wriggle)
1491   (cond ((not (kern-place-move-is-passable? (kern-obj-get-location caster)
1492                                             ktarg caster))
1493          (kern-log-msg "Wriggle failed: blocked!")
1494          (kern-obj-set-mmode caster nil)
1495          result-not-here)
1496         (else
1497          (kern-obj-relocate caster ktarg nil)
1498          (kern-obj-set-mmode caster nil)
1499          (cond ((passable? (kern-obj-get-location caster) caster)
1500                 (kern-log-msg "(Was that really necessary?)")
1501                 result-ok
1502                 )
1503                ((not (check-roll dc-avoid-stuck (occ-thief-dice-roll caster)))
1504                 (kern-obj-add-effect caster ef_stuck nil)
1505                 result-failed
1506                 )
1507                (else
1508                 result-ok
1509                 )))))
1510
1511 (define (powers-butcher caster ktarg power)
1512   (if ((kobj-ifc ktarg) 'butcher ktarg caster)
1513       result-ok
1514       result-no-effect))
1515
1516 (define (powers-pickpocket kactor ktarg power)
1517   (cond ((contest-of-skill power (occ-ability-thief ktarg))
1518          (let ((ktype (kern-ui-select-item ktarg)))
1519            (cond ((null? ktype) result-no-effect)
1520                  (else
1521                   (kern-obj-remove-from-inventory ktarg ktype 1)
1522                   (if (ktype-can? ktype 'receive)
1523                         ((kern-type-get-gifc ktype) 'receive ktype kactor)
1524                   )
1525                   (kern-obj-add-to-inventory kactor ktype 1)
1526                   result-ok
1527                   ))))
1528         (else
1529          (harm-relations kactor ktarg)
1530          result-failed
1531          )))
1532