worlds/haxima-1.002/ability.scm

   1 ;;----------------------------------------------------------------------------
   2 ;; Ability "class"
   3 ;;----------------------------------------------------------------------------
   4
   5 (define default-aap 50)
   6
   7 (define (mk-ability name level mana ap rng proc)
   8   (list name level mana (* ap default-aap) proc rng))
   9
  10 (define (ability-name ability) (car ability))
  11 (define (ability-level-required ability) (cadr ability))
  12 (define (ability-mana-cost ability) (caddr ability))
  13 (define (ability-ap-cost ability) (cadddr ability))
  14 (define (ability-proc ability) (list-ref ability 4))
  15 (define (ability-range ability) (list-ref ability 5))
  16
  17 (define (can-use-ability? ability kchar)
  18   ;;(println " can-use-ability?" display ability)
  19   (and (<= (kern-get-magic-negated) 0)
  20        (>= (kern-char-get-mana kchar)
  21            (ability-mana-cost ability))
  22        (>= (kern-char-get-level kchar)
  23            (ability-level-required ability))))
  24
  25 (define (use-ability ability kchar . args)
  26   (let ((result (apply (ability-proc ability) (cons kchar args))))
  27          (if result
  28                 (begin
  29                   (kern-char-dec-mana kchar (ability-mana-cost ability))
  30                   (kern-obj-dec-ap kchar (ability-ap-cost ability))
  31                 )
  32          )
  33     (if (<= (kern-char-get-mana kchar) 0)
  34         (kern-log-msg (kern-obj-get-name kchar) " is exhausted!"))
  35     result))
  36
  37
  38 ;;----------------------------------------------------------------------------
  39 ;; Ability procedures
  40 ;;----------------------------------------------------------------------------
  41
  42 (define (vampiric-touch-proc kchar ktarg)
  43   (let ((amount (min (* (kern-dice-roll "1d3")
  44                         (kern-char-get-level kchar))
  45                      (kern-char-get-hp ktarg))))
  46     (kern-obj-inc-ref ktarg)
  47     (kern-obj-apply-damage ktarg "life drained" amount)
  48     (kern-obj-heal kchar amount)
  49     (kern-log-msg (kern-obj-get-name kchar)
  50                   " drains life from "
  51                   (kern-obj-get-name ktarg)
  52                   "!")
  53     (kern-obj-dec-ref ktarg))
  54   #t)
  55
  56 (define (disease-touch-proc kchar ktarg)
  57   (if (kern-obj-add-effect ktarg ef_disease nil)
  58       (kern-log-msg (kern-obj-get-name kchar)
  59                     " inflicts "
  60                     (kern-obj-get-name ktarg)
  61                     " with Disease!"))
  62   #t)
  63
  64 (define (disarm kchar ktarg)
  65   (let ((readied (kern-char-get-readied-weapons ktarg)))
  66     (if (null? readied)
  67         #f
  68         (if (> (kern-char-get-level kchar)
  69                (+ (kern-dice-roll "1d3-1")
  70                   (kern-char-get-level ktarg)))
  71             (let ((ktype (random-select readied)))
  72               (kern-log-msg (kern-obj-get-name kchar)
  73                             " disarms "
  74                             (kern-obj-get-name ktarg))
  75               (kern-char-unready ktarg ktype)
  76               (kern-obj-remove-from-inventory ktarg ktype 1)
  77               (kern-obj-put-at (kern-mk-obj ktype 1)
  78                                (kern-obj-get-location ktarg))
  79               )
  80             (kern-log-msg  (kern-obj-get-name kchar)
  81                            " fails to disarm "
  82                            (kern-obj-get-name ktarg))
  83             #t))))
  84
  85 (define (heal-proc kchar ktarg)
  86   (kern-log-msg (kern-obj-get-name kchar)
  87                 " casts a healing spell on "
  88                 (if (eqv? kchar ktarg)
  89                     "self"
  90                     (kern-obj-get-name ktarg)))
  91         (kern-obj-heal ktarg
  92                 (+ 2 (kern-dice-roll "1d10")
  93                         (kern-dice-roll (string-append "2d" (number->string (occ-ability-whitemagic kchar)))))))
  94
  95 (define (great-heal-proc kchar ktarg)
  96   (kern-log-msg (kern-obj-get-name kchar)
  97                 " casts a great healing spell on "
  98                 (if (eqv? kchar ktarg)
  99                     "self"
 100                     (kern-obj-get-name ktarg)))
 101   (kern-obj-heal ktarg (kern-dice-roll "4d20+20")))
 102
 103 ;;----------------------------------------------------------------------------
 104 ;; field spells
 105 (define (cast-field-proc kchar loc ktype)
 106   (kern-log-msg (kern-obj-get-name kchar)
 107                 " casts "(kern-type-get-name ktype) "!")
 108   (kern-obj-put-at (kern-mk-obj ktype 1) loc))
 109
 110 (define (cast-fire-field-proc kchar ktarg)
 111   (cast-field-proc kchar
 112                    (kern-obj-get-location ktarg)
 113                    F_fire))
 114
 115 (define (cast-poison-field-proc kchar ktarg)
 116   (cast-field-proc kchar
 117                    (kern-obj-get-location ktarg)
 118                    F_poison))
 119
 120 (define (cast-sleep-field-proc kchar ktarg)
 121   (cast-field-proc kchar
 122                    (kern-obj-get-location ktarg)
 123                    F_sleep))
 124
 125 (define (cast-energy-field-proc kchar ktarg)
 126   (cast-field-proc kchar
 127                    (kern-obj-get-location ktarg)
 128                    F_energy))
 129
 130 ;;----------------------------------------------------------------------------
 131 ;; missile spells
 132
 133 ;; cast-magic-missile-proc -- damage goes up with level of caster
 134 (define (cast-magic-missile-proc kchar ktarg)
 135         (powers-magic-missile kchar ktarg (occ-ability-blackmagic kchar)))
 136
 137 (define (cast-poison-missile-proc kchar ktarg)
 138         (powers-poison kchar ktarg (occ-ability-blackmagic kchar)))
 139
 140 (define (cast-fireball-proc kchar ktarg)
 141         (let ((target (kern-obj-get-location ktarg))
 142                         (power (occ-ability-blackmagic kchar)))
 143                 (and (powers-fireball-collateral-check kchar target power)
 144                         (powers-fireball kchar target power))
 145         ))
 146
 147 (define (cast-kill-proc kchar ktarg)
 148   (kern-log-msg (kern-obj-get-name kchar)
 149                 " casts kill at "
 150                 (kern-obj-get-name ktarg))
 151   (cast-missile-proc kchar ktarg t_deathball))
 152
 153 (define (cast-acid-missile-proc kchar ktarg)
 154   (kern-log-msg (kern-obj-get-name kchar)
 155                 " hurls acid missile at "
 156                 (kern-obj-get-name ktarg))
 157   (cast-missile-proc kchar ktarg t_acid_bolt))
 158
 159 (define (web-spew-proc kchar ktarg)
 160   (kern-log-msg (kern-obj-get-name kchar)
 161                 " spews web at "
 162                 (kern-obj-get-name ktarg))
 163   (define (spew-in-dir dir)
 164     (define (ensnare-loc loc)
 165       (kern-obj-put-at (kern-mk-obj web-type 1) loc))
 166     (let ((loc (kern-obj-get-location kchar)))
 167       (cast-wind-spell2 loc
 168                         ensnare-loc
 169                         dir
 170                         (/ (kern-char-get-level kchar) 2))))
 171   (let* ((v (loc-diff (kern-obj-get-location kchar)
 172                       (kern-obj-get-location ktarg)
 173                       ))
 174          (dir (loc-to-cardinal-dir v)))
 175     (spew-in-dir dir)))
 176
 177 (define (teleport-proc kchar loc)
 178   (kern-log-msg (kern-obj-get-name kchar)
 179                 " teleports")
 180   (kern-obj-relocate kchar loc nil))
 181
 182 (define (fire-wind-proc3 kchar ktarg)
 183   (kern-log-msg (kern-obj-get-name kchar)
 184                 " blasts fire at "
 185                 (kern-obj-get-name ktarg))
 186   (define (spew-in-dir dir)
 187     (define (ensnare-loc loc)
 188       (kern-obj-put-at (kern-mk-obj F_fire 1) loc))
 189     (let ((loc (kern-obj-get-location kchar)))
 190       (cast-wind-spell2 loc
 191                         ensnare-loc
 192                         dir
 193                         4)))
 194   (let* ((v (loc-diff (kern-obj-get-location kchar)
 195                       (kern-obj-get-location ktarg)
 196                       ))
 197          (dir (loc-to-cardinal-dir v)))
 198     (spew-in-dir dir)))
 199
 200 (define (fire-wind-proc kchar ktarg)
 201         ;;(println "flamewind")
 202         (let ((target (kern-obj-get-location ktarg))
 203                         (power (occ-ability-blackmagic kchar)))
 204                 (and (powers-cone-fire-test kchar target power)
 205                         (begin
 206                                 ;;(println "flamewind2")
 207                                 (kern-log-msg (kern-obj-get-name kchar)
 208                         " blasts fire at "
 209                         (kern-obj-get-name ktarg))
 210                         (powers-cone-fire kchar target power)
 211                   ))
 212         ))
 213
 214 (define (lightning-bolt-proc kchar ktarg)
 215         (let ((target (kern-obj-get-location ktarg))
 216                         (power (occ-ability-blackmagic kchar)))
 217                 (and (powers-lightning-collateral-check kchar target power)
 218                         (begin (kern-log-msg (kern-obj-get-name kchar)
 219                         " streams lightning at "
 220                         (kern-obj-get-name ktarg))
 221                         (powers-lightning kchar target power)
 222                    ))
 223         ))
 224
 225
 226 ;;----------------------------------------------------------------------------
 227 ;; summoning
 228 (define (cast-summon-proc kchar gen-npct quantity)
 229   (define (run-loop count)
 230     (cond ((<= count 0) 0)
 231           (else
 232            (let* ((lvl (+ (kern-dice-roll "1d2") (/ (kern-char-get-level kchar) 2)))
 233                   (knpc (spawn-npc (gen-npct) lvl))
 234                   (loc (pick-loc (kern-obj-get-location kchar) knpc))
 235                   )
 236              (cond ((null? loc)
 237                     (kern-obj-dec-ref knpc)
 238                     0)
 239                    (else
 240                     (kern-being-set-base-faction knpc (kern-being-get-base-faction kchar))
 241                     (kern-obj-set-temporary knpc #t)
 242                     (kern-obj-put-at knpc loc)
 243                     (+ 1 (run-loop (- count 1)))))))))
 244   (cond ((> (run-loop quantity)
 245             0)
 246          (kern-log-msg (kern-obj-get-name kchar) " summons help")
 247          #t)
 248         (else
 249          (kern-log-msg (kern-obj-get-name kchar) " fails to summon help")
 250          #f)))
 251
 252 (define (summon-skeleton-proc kchar)
 253   ;;(println "summon-skeleton-proc")
 254   (cast-summon-proc kchar
 255                     (lambda ()
 256                       (random-select (list 'skeletal-warrior 'skeletal-spear-thrower)))
 257                     (/ (kern-char-get-level kchar) 2)
 258                     ))
 259
 260 (define (summon-slime-proc kchar)
 261   ;;(println "summon-slime-proc")
 262   (cast-summon-proc kchar
 263                     (lambda () 'green-slime)
 264                     (/ (kern-char-get-level kchar) 2)
 265                     ))
 266
 267 (define (summon-demon-proc kchar)
 268   (cast-summon-proc kchar
 269                     (lambda () 'demon)
 270                     1))
 271
 272 (define (summon-wolf-proc kchar)
 273   (cast-summon-proc kchar
 274                     (lambda () 'wolf)
 275                     1))
 276
 277 (define (summon-ratling-proc kchar)
 278   (cast-summon-proc kchar
 279                     (lambda () 'ratling-swarmer)
 280                     (* (kern-char-get-level kchar) 3)
 281                     ))
 282
 283 ;;----------------------------------------------------------------------------
 284 ;; enslave -- aka charm
 285 (define (enslave-proc kchar ktarg)
 286   (kern-log-msg (kern-obj-get-name kchar)
 287                 " enslaves "
 288                 (kern-obj-get-name ktarg))
 289   (kern-obj-add-effect ktarg
 290                        ef_charm
 291                        (charm-mk (kern-being-get-current-faction kchar))))
 292
 293 ;;----------------------------------------------------------------------------
 294 ;; chomp-deck -- convert deck terrain into shallow water terrain
 295 (define (chomp-deck-proc kchar loc)
 296   (cond ((not (is-deck? (kern-place-get-terrain loc))) #f)
 297                   ((not (null? (get-being-at loc))) #f)
 298         (else
 299          (kern-place-set-terrain loc t_shallow)
 300          (msg-log-visible (kern-obj-get-location kchar) (kern-obj-get-name kchar) " chomps through the deck!")
 301          (map kern-obj-remove
 302                 (kern-get-objects-at loc))
 303          (if (kern-place-is-combat-map? (loc-place loc))
 304                                 (let* ((vehicle (kern-party-get-vehicle (kern-get-player))))
 305                                         (if (not (null? vehicle))
 306                                                 (begin
 307                                                    (shake-map 10)
 308                                                         (kern-obj-apply-damage vehicle "breakage" (floor (/ (kern-obj-get-hp vehicle) 7)))
 309                                                 )
 310                                         )
 311                                 )
 312                         )
 313          #t)))
 314
 315 (define (deck-to-sludge-proc kchar loc)
 316   (cond ((not (is-deck? (kern-place-get-terrain loc))) #f)
 317         (else
 318          (kern-place-set-terrain loc t_shallow_sludge)
 319          (kern-log-msg (kern-obj-get-name kchar) " chomps through the deck!")
 320          #t)))
 321
 322 ;;----------------------------------------------------------------------------
 323 ;; narcotize -- mass sleep
 324 (define (narcotize-proc kchar)
 325   (let ((hostiles (all-hostiles kchar)))
 326     (cond ((null? hostiles) #f)
 327           (else
 328            (kern-log-msg (kern-obj-get-name kchar)
 329                          " beckons slumber to its foes")
 330            (map (lambda (ktarg)
 331                   (if (> (- (+ (kern-dice-roll "1d20")
 332                                (kern-char-get-level kchar))
 333                             (kern-char-get-level ktarg))
 334                          12)
 335                       (begin
 336                         (apply-sleep ktarg)
 337                         (kern-log-msg (kern-obj-get-name ktarg) " succumbs!")
 338                         )
 339                       (kern-log-msg (kern-obj-get-name ktarg) " resists!")))
 340                 hostiles)
 341            #t))))
 342
 343 ;;----------------------------------------------------------------------------
 344 ;; turn invisible
 345 (define (turn-invisible-proc kchar)
 346   (kern-log-msg (kern-obj-get-name kchar)
 347                 " vanishes!")
 348   (kern-obj-add-effect kchar ef_invisibility nil))
 349
 350 ;;----------------------------------------------------------------------------
 351 ;; Ability declarations
 352 ;;
 353 ;;  L = level
 354 ;;  M = mana
 355 ;;  A = action points
 356 ;;  R = range
 357 ;;
 358 ;;----------------------------------------------------------------------------
 359
 360 ;;                                      name                  L M A R proc
 361 (define vampiric-touch      (mk-ability "vampiric touch"      3 3 2 1 vampiric-touch-proc))
 362 (define disease-touch       (mk-ability "disease touch"       6 6 1 1 disease-touch-proc))
 363 (define disarm              (mk-ability "disarm"              4 2 2 1 disarm))
 364 (define heal-ability        (mk-ability "heal"                1 1 1 2 heal-proc))
 365 (define great-heal-ability  (mk-ability "great heal"          4 4 2 2 great-heal-proc))
 366 (define cast-fire-field     (mk-ability "cast fire field"     3 3 2 1 cast-fire-field-proc))
 367 (define cast-poison-field   (mk-ability "cast poison field"   3 3 2 1 cast-poison-field-proc))
 368 (define cast-sleep-field    (mk-ability "cast sleep field"    3 3 2 1 cast-sleep-field-proc))
 369 (define cast-energy-field   (mk-ability "cast energy field"   4 4 2 1 cast-energy-field-proc))
 370 (define cast-magic-missile  (mk-ability "cast magic missile"  1 1 1 6 cast-magic-missile-proc))
 371 (define cast-poison-missile (mk-ability "cast poison missile" 2 2 1 6 cast-poison-missile-proc))
 372 (define cast-fireball       (mk-ability "cast fireball"       3 3 1 6 cast-fireball-proc))
 373 (define cast-kill           (mk-ability "cast kill"           7 7 2 4 cast-kill-proc))
 374 (define cast-acid-missile   (mk-ability "cast acid missile"   4 4 1 4 cast-acid-missile-proc))
 375 (define web-spew            (mk-ability "spew web"            4 4 2 5 web-spew-proc))
 376 (define teleport            (mk-ability "teleport"            6 6 2 0 teleport-proc))
 377 (define summon-skeleton     (mk-ability "summon skeleton"     6 6 4 0 summon-skeleton-proc))
 378 (define summon-slimes       (mk-ability "summon slimes"       2 2 3 0 summon-slime-proc))
 379 (define summon-demon        (mk-ability "summon demon"        8 8 6 0 summon-demon-proc))
 380 (define summon-wolves       (mk-ability "summon wolves"       4 4 2 0 summon-wolf-proc))
 381 (define summon-ratlings     (mk-ability "summon ratlings"     1 2 4 0 summon-ratling-proc))
 382 (define chomp-deck          (mk-ability "chomp deck"          2 4 3 1 chomp-deck-proc))
 383 (define deck-to-sludge      (mk-ability "chomp deck"          1 1 1 1 deck-to-sludge-proc))
 384 (define enslave             (mk-ability "enslave"             3 4 2 4 enslave-proc))
 385 (define narcotize           (mk-ability "narcotize"           5 6 3 0 narcotize-proc))
 386 (define cast-fire-wind      (mk-ability "fire wind"           6 6 2 9 fire-wind-proc))
 387 (define turn-invisible      (mk-ability "turn invisible"      7 7 2 0 turn-invisible-proc))
 388 (define cast-lightning-bolt (mk-ability "lightning bolt"      4 4 2 9 lightning-bolt-proc))
 389
 390 ;;----------------------------------------------------------------------------
 391 ;; Abilities listed by various attributes
 392 ;;----------------------------------------------------------------------------
 393
 394 (define melee-spells
 395   (list cast-fire-field
 396         cast-sleep-field
 397         cast-poison-field
 398         cast-energy-field))
 399
 400 (define all-field-spells
 401   (list cast-fire-field
 402         cast-poison-field
 403         cast-sleep-field
 404         cast-energy-field
 405         ))
 406
 407 ;; ranged-spells -- damaging spells which take a target kchar as an arg.
 408 (define fireball-spell cast-fireball)
 409 (define poison-missile-spell cast-poison-missile)
 410 (define acid-missile-spell cast-acid-missile)
 411 (define kill-spell cast-kill)
 412 (define all-ranged-spells
 413   (list
 414    cast-magic-missile
 415    poison-missile-spell
 416    fireball-spell
 417    cast-fire-wind
 418    cast-acid-missile
 419    cast-lightning-bolt
 420    ))
 421