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) "¤ÏÇ½ÎÏ¤ò»È¤¤²Ì¤¿¤·¤¿¡ª"))
  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                   "¤Ï"
  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                     "¤Ï"
  60                     (kern-obj-get-name ktarg)
  61                     "¤òØí´µ¤µ¤»¤¿¡ª"))
  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                             "¤Ï"
  74                             (kern-obj-get-name ktarg)
  75                             "¤ÎÁõÈ÷¤ò³°¤·¤¿¡£")
  76               (kern-char-unready ktarg ktype)
  77               (kern-obj-remove-from-inventory ktarg ktype 1)
  78               (kern-obj-put-at (kern-mk-obj ktype 1)
  79                                (kern-obj-get-location ktarg))
  80               )
  81             (kern-log-msg  (kern-obj-get-name kchar)
  82                            "¤Ï"
  83                            (kern-obj-get-name ktarg)
  84                            "¤ÎÁõÈ÷¤ò³°¤»¤Ê¤«¤Ã¤¿¡£")
  85             #t))))
  86
  87 (define (heal-proc kchar ktarg)
  88   (kern-log-msg (kern-obj-get-name kchar)
  89                 "¤Ï²óÉü¤Î¼öÊ¸¤ò"
  90                 (if (eqv? kchar ktarg)
  91                     "¼«Ê¬"
  92                     (kern-obj-get-name ktarg))
  93                 "¤Ë¤«¤±¤¿¡£")
  94         (kern-obj-heal ktarg
  95                 (+ 2 (kern-dice-roll "1d10")
  96                         (kern-dice-roll (string-append "2d" (number->string (occ-ability-whitemagic kchar)))))))
  97
  98 (define (great-heal-proc kchar ktarg)
  99   (kern-log-msg (kern-obj-get-name kchar)
 100                 "¤ÏÂç²óÉü¤Î¼öÊ¸¤ò"
 101                 (if (eqv? kchar ktarg)
 102                     "¼«Ê¬"
 103                     (kern-obj-get-name ktarg))
 104                 "¤Ë¤«¤±¤¿¡£")
 105   (kern-obj-heal ktarg (kern-dice-roll "4d20+20")))
 106
 107 ;;----------------------------------------------------------------------------
 108 ;; field spells
 109 (define (cast-field-proc kchar loc ktype)
 110   (kern-log-msg (kern-obj-get-name kchar)
 111                 "¤Ï"(kern-type-get-name ktype) "¤Î¼öÊ¸¤ò¤«¤±¤¿¡ª")
 112   (kern-obj-put-at (kern-mk-obj ktype 1) loc))
 113
 114 (define (cast-fire-field-proc kchar ktarg)
 115   (cast-field-proc kchar
 116                    (kern-obj-get-location ktarg)
 117                    F_fire))
 118
 119 (define (cast-poison-field-proc kchar ktarg)
 120   (cast-field-proc kchar
 121                    (kern-obj-get-location ktarg)
 122                    F_poison))
 123
 124 (define (cast-sleep-field-proc kchar ktarg)
 125   (cast-field-proc kchar
 126                    (kern-obj-get-location ktarg)
 127                    F_sleep))
 128
 129 (define (cast-energy-field-proc kchar ktarg)
 130   (cast-field-proc kchar
 131                    (kern-obj-get-location ktarg)
 132                    F_energy))
 133
 134 ;;----------------------------------------------------------------------------
 135 ;; missile spells
 136
 137 ;; cast-magic-missile-proc -- damage goes up with level of caster
 138 (define (cast-magic-missile-proc kchar ktarg)
 139         (powers-magic-missile kchar ktarg (occ-ability-blackmagic kchar)))
 140
 141 (define (cast-poison-missile-proc kchar ktarg)
 142         (powers-poison kchar ktarg (occ-ability-blackmagic kchar)))
 143
 144 (define (cast-fireball-proc kchar ktarg)
 145         (let ((target (kern-obj-get-location ktarg))
 146                         (power (occ-ability-blackmagic kchar)))
 147                 (and (powers-fireball-collateral-check kchar target power)
 148                         (powers-fireball kchar target power))
 149         ))
 150
 151 (define (cast-kill-proc kchar ktarg)
 152   (kern-log-msg (kern-obj-get-name kchar)
 153                 "¤Ï"
 154                 (kern-obj-get-name ktarg)
 155                 "¤Ë»à¤Î¼öÊ¸¤ò¤«¤±¤¿¡£")
 156   (cast-missile-proc kchar ktarg t_deathball))
 157
 158 (define (cast-acid-missile-proc kchar ktarg)
 159   (kern-log-msg (kern-obj-get-name kchar)
 160                 "¤Ï"
 161                 (kern-obj-get-name ktarg)
 162                 "¤Ë»À¤òÍá¤Ó¤»¤¿¡£")
 163   (cast-missile-proc kchar ktarg t_acid_bolt))
 164
 165 (define (web-spew-proc kchar ktarg)
 166   (kern-log-msg (kern-obj-get-name kchar)
 167                 "¤Ï"
 168                 (kern-obj-get-name ktarg)
 169                 "¤ËÌÖ¤òÊü¤Ã¤¿¡£")
 170   (define (spew-in-dir dir)
 171     (define (ensnare-loc loc)
 172       (kern-obj-put-at (kern-mk-obj web-type 1) loc))
 173     (let ((loc (kern-obj-get-location kchar)))
 174       (cast-wind-spell2 loc
 175                         ensnare-loc
 176                         dir
 177                         (/ (kern-char-get-level kchar) 2))))
 178   (let* ((v (loc-diff (kern-obj-get-location kchar)
 179                       (kern-obj-get-location ktarg)
 180                       ))
 181          (dir (loc-to-cardinal-dir v)))
 182     (spew-in-dir dir)))
 183
 184 (define (teleport-proc kchar loc)
 185   (kern-log-msg (kern-obj-get-name kchar)
 186                 "¤Ï½Ö´Ö°ÜÆ°¤·¤¿¡£")
 187   (kern-obj-relocate kchar loc nil))
 188
 189 (define (fire-wind-proc3 kchar ktarg)
 190   (kern-log-msg (kern-obj-get-name kchar)
 191                 "¤Ï"
 192                 (kern-obj-get-name ktarg)
 193                 "¤Ë¸þ¤«¤Ã¤Æ±ê¤ÎÉ÷¤òÊü¤Ã¤¿¡£")
 194   (define (spew-in-dir dir)
 195     (define (ensnare-loc loc)
 196       (kern-obj-put-at (kern-mk-obj F_fire 1) loc))
 197     (let ((loc (kern-obj-get-location kchar)))
 198       (cast-wind-spell2 loc
 199                         ensnare-loc
 200                         dir
 201                         4)))
 202   (let* ((v (loc-diff (kern-obj-get-location kchar)
 203                       (kern-obj-get-location ktarg)
 204                       ))
 205          (dir (loc-to-cardinal-dir v)))
 206     (spew-in-dir dir)))
 207
 208 (define (fire-wind-proc kchar ktarg)
 209         ;;(println "flamewind")
 210         (let ((target (kern-obj-get-location ktarg))
 211                         (power (occ-ability-blackmagic kchar)))
 212                 (and (powers-cone-fire-test kchar target power)
 213                         (begin
 214                                 ;;(println "flamewind2")
 215                                 (kern-log-msg (kern-obj-get-name kchar)
 216                         "¤Ï"
 217                         (kern-obj-get-name ktarg)
 218                         "¤Ë¸þ¤«¤Ã¤Æ±ê¤ÎÉ÷¤òÊü¤Ã¤¿¡£")
 219                         (powers-cone-fire kchar target power)
 220                   ))
 221         ))
 222
 223 (define (lightning-bolt-proc kchar ktarg)
 224         (let ((target (kern-obj-get-location ktarg))
 225                         (power (occ-ability-blackmagic kchar)))
 226                 (and (powers-lightning-collateral-check kchar target power)
 227                         (begin (kern-log-msg (kern-obj-get-name kchar)
 228                         "¤Ï"
 229                         (kern-obj-get-name ktarg)
 230                         "¤Ë°ðºÊ¤òÊü¤Ã¤¿¡£")
 231                         (powers-lightning kchar target power)
 232                    ))
 233         ))
 234
 235
 236 ;;----------------------------------------------------------------------------
 237 ;; summoning
 238 (define (cast-summon-proc kchar gen-npct quantity)
 239   (define (run-loop count)
 240     (cond ((<= count 0) 0)
 241           (else
 242            (let* ((lvl (+ (kern-dice-roll "1d2") (/ (kern-char-get-level kchar) 2)))
 243                   (knpc (spawn-npc (gen-npct) lvl))
 244                   (loc (pick-loc (kern-obj-get-location kchar) knpc))
 245                   )
 246              (cond ((null? loc)
 247                     (kern-obj-dec-ref knpc)
 248                     0)
 249                    (else
 250                     (kern-being-set-base-faction knpc (kern-being-get-base-faction kchar))
 251                     (kern-obj-set-temporary knpc #t)
 252                     (kern-obj-put-at knpc loc)
 253                     (+ 1 (run-loop (- count 1)))))))))
 254   (cond ((> (run-loop quantity)
 255             0)
 256          (kern-log-msg (kern-obj-get-name kchar) "¤ÏÃç´Ö¤ò¾¤´Ô¤·¤¿¡£")
 257          #t)
 258         (else
 259          (kern-log-msg (kern-obj-get-name kchar) "¤Ï¾¤´Ô¤Ë¼ºÇÔ¤·¤¿¡£")
 260          #f)))
 261
 262 (define (summon-skeleton-proc kchar)
 263   ;;(println "summon-skeleton-proc")
 264   (cast-summon-proc kchar
 265                     (lambda ()
 266                       (random-select (list 'skeletal-warrior 'skeletal-spear-thrower)))
 267                     (/ (kern-char-get-level kchar) 2)
 268                     ))
 269
 270 (define (summon-slime-proc kchar)
 271   ;;(println "summon-slime-proc")
 272   (cast-summon-proc kchar
 273                     (lambda () 'green-slime)
 274                     (/ (kern-char-get-level kchar) 2)
 275                     ))
 276
 277 (define (summon-demon-proc kchar)
 278   (cast-summon-proc kchar
 279                     (lambda () 'demon)
 280                     1))
 281
 282 (define (summon-wolf-proc kchar)
 283   (cast-summon-proc kchar
 284                     (lambda () 'wolf)
 285                     1))
 286
 287 (define (summon-ratling-proc kchar)
 288   (cast-summon-proc kchar
 289                     (lambda () 'ratling-swarmer)
 290                     (* (kern-char-get-level kchar) 3)
 291                     ))
 292
 293 ;;----------------------------------------------------------------------------
 294 ;; enslave -- aka charm
 295 (define (enslave-proc kchar ktarg)
 296   (kern-log-msg (kern-obj-get-name kchar)
 297                 "¤Ï"
 298                 (kern-obj-get-name ktarg)
 299                 "¤òÅÛÎì¤Ë¤·¤¿¡£")
 300   (kern-obj-add-effect ktarg
 301                        ef_charm
 302                        (charm-mk (kern-being-get-current-faction kchar))))
 303
 304 ;;----------------------------------------------------------------------------
 305 ;; chomp-deck -- convert deck terrain into shallow water terrain
 306 (define (chomp-deck-proc kchar loc)
 307   (cond ((not (is-deck? (kern-place-get-terrain loc))) #f)
 308                   ((not (null? (get-being-at loc))) #f)
 309         (else
 310          (kern-place-set-terrain loc t_shallow)
 311          (msg-log-visible (kern-obj-get-location kchar) (kern-obj-get-name kchar) "¤Ï¹ÃÈÄ¤ò´Ó¤¤¤¿¡ª")
 312          (map kern-obj-remove
 313                 (kern-get-objects-at loc))
 314          (if (kern-place-is-combat-map? (loc-place loc))
 315                                 (let* ((vehicle (kern-party-get-vehicle (kern-get-player))))
 316                                         (if (not (null? vehicle))
 317                                                 (begin
 318                                                    (shake-map 10)
 319                                                         (kern-obj-apply-damage vehicle "breakage" (floor (/ (kern-obj-get-hp vehicle) 7)))
 320                                                 )
 321                                         )
 322                                 )
 323                         )
 324          #t)))
 325
 326 (define (deck-to-sludge-proc kchar loc)
 327   (cond ((not (is-deck? (kern-place-get-terrain loc))) #f)
 328         (else
 329          (kern-place-set-terrain loc t_shallow_sludge)
 330          (kern-log-msg (kern-obj-get-name kchar) "¤Ï¹ÃÈÄ¤ò´Ó¤¤¤¿¡ª")
 331          #t)))
 332
 333 ;;----------------------------------------------------------------------------
 334 ;; narcotize -- mass sleep
 335 (define (narcotize-proc kchar)
 336   (let ((hostiles (all-hostiles kchar)))
 337     (cond ((null? hostiles) #f)
 338           (else
 339            (kern-log-msg (kern-obj-get-name kchar)
 340                          "¤Ï´ñÌ¯¤Ê¼ê¿¶¤ê¤ÇÅ¨¤òÌ²¤é¤»¤è¤¦¤È¤·¤¿¡£")
 341            (map (lambda (ktarg)
 342                   (if (> (- (+ (kern-dice-roll "1d20")
 343                                (kern-char-get-level kchar))
 344                             (kern-char-get-level ktarg))
 345                          12)
 346                       (begin
 347                         (apply-sleep ktarg)
 348                         (kern-log-msg (kern-obj-get-name ktarg) "¤ÏÌ²¤Ã¤¿¡ª")
 349                         )
 350                       (kern-log-msg (kern-obj-get-name ktarg) "¤ÏÄñ¹³¤·¤¿¡ª")))
 351                 hostiles)
 352            #t))))
 353
 354 ;;----------------------------------------------------------------------------
 355 ;; turn invisible
 356 (define (turn-invisible-proc kchar)
 357   (kern-log-msg (kern-obj-get-name kchar)
 358                 "¤Ï¾Ã¤¨¤¿¡ª")
 359   (kern-obj-add-effect kchar ef_invisibility nil))
 360
 361 ;;----------------------------------------------------------------------------
 362 ;; Ability declarations
 363 ;;
 364 ;;  L = level
 365 ;;  M = mana
 366 ;;  A = action points
 367 ;;  R = range
 368 ;;
 369 ;;----------------------------------------------------------------------------
 370
 371 ;;                                      name                  L M A R proc
 372 (define vampiric-touch      (mk-ability "vampiric touch"      3 3 2 1 vampiric-touch-proc))
 373 (define disease-touch       (mk-ability "disease touch"       6 6 1 1 disease-touch-proc))
 374 (define disarm              (mk-ability "disarm"              4 2 2 1 disarm))
 375 (define heal-ability        (mk-ability "heal"                1 1 1 2 heal-proc))
 376 (define great-heal-ability  (mk-ability "great heal"          4 4 2 2 great-heal-proc))
 377 (define cast-fire-field     (mk-ability "cast fire field"     3 3 2 1 cast-fire-field-proc))
 378 (define cast-poison-field   (mk-ability "cast poison field"   3 3 2 1 cast-poison-field-proc))
 379 (define cast-sleep-field    (mk-ability "cast sleep field"    3 3 2 1 cast-sleep-field-proc))
 380 (define cast-energy-field   (mk-ability "cast energy field"   4 4 2 1 cast-energy-field-proc))
 381 (define cast-magic-missile  (mk-ability "cast magic missile"  1 1 1 6 cast-magic-missile-proc))
 382 (define cast-poison-missile (mk-ability "cast poison missile" 2 2 1 6 cast-poison-missile-proc))
 383 (define cast-fireball       (mk-ability "cast fireball"       3 3 1 6 cast-fireball-proc))
 384 (define cast-kill           (mk-ability "cast kill"           7 7 2 4 cast-kill-proc))
 385 (define cast-acid-missile   (mk-ability "cast acid missile"   4 4 1 4 cast-acid-missile-proc))
 386 (define web-spew            (mk-ability "spew web"            4 4 2 5 web-spew-proc))
 387 (define teleport            (mk-ability "teleport"            6 6 2 0 teleport-proc))
 388 (define summon-skeleton     (mk-ability "summon skeleton"     6 6 4 0 summon-skeleton-proc))
 389 (define summon-slimes       (mk-ability "summon slimes"       2 2 3 0 summon-slime-proc))
 390 (define summon-demon        (mk-ability "summon demon"        8 8 6 0 summon-demon-proc))
 391 (define summon-wolves       (mk-ability "summon wolves"       4 4 2 0 summon-wolf-proc))
 392 (define summon-ratlings     (mk-ability "summon ratlings"     1 2 4 0 summon-ratling-proc))
 393 (define chomp-deck          (mk-ability "chomp deck"          2 4 3 1 chomp-deck-proc))
 394 (define deck-to-sludge      (mk-ability "chomp deck"          1 1 1 1 deck-to-sludge-proc))
 395 (define enslave             (mk-ability "enslave"             3 4 2 4 enslave-proc))
 396 (define narcotize           (mk-ability "narcotize"           5 6 3 0 narcotize-proc))
 397 (define cast-fire-wind      (mk-ability "fire wind"           6 6 2 9 fire-wind-proc))
 398 (define turn-invisible      (mk-ability "turn invisible"      7 7 2 0 turn-invisible-proc))
 399 (define cast-lightning-bolt (mk-ability "lightning bolt"      4 4 2 9 lightning-bolt-proc))
 400
 401 ;;----------------------------------------------------------------------------
 402 ;; Abilities listed by various attributes
 403 ;;----------------------------------------------------------------------------
 404
 405 (define melee-spells
 406   (list cast-fire-field
 407         cast-sleep-field
 408         cast-poison-field
 409         cast-energy-field))
 410
 411 (define all-field-spells
 412   (list cast-fire-field
 413         cast-poison-field
 414         cast-sleep-field
 415         cast-energy-field
 416         ))
 417
 418 ;; ranged-spells -- damaging spells which take a target kchar as an arg.
 419 (define fireball-spell cast-fireball)
 420 (define poison-missile-spell cast-poison-missile)
 421 (define acid-missile-spell cast-acid-missile)
 422 (define kill-spell cast-kill)
 423 (define all-ranged-spells
 424   (list
 425    cast-magic-missile
 426    poison-missile-spell
 427    fireball-spell
 428    cast-fire-wind
 429    cast-acid-missile
 430    cast-lightning-bolt
 431    ))
 432