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
422