Commit | Line | Data |
---|---|---|
46d528a4 MW |
1 | ;;; |
2 | ||
3 | (defun d (n &optional (k 1) &key (bias 0) best worst) | |
4 | (let ((rolls (sort (loop repeat k | |
5 | collect (1+ (max 0 (min (1- n) | |
6 | (+ (random n) bias))))) | |
7 | #'<))) | |
8 | (reduce #'+ (cond (best (subseq rolls (- k best))) | |
9 | (worst (subseq rolls 0 worst)) | |
10 | (t rolls))))) | |
11 | ||
12 | (defvar *dnd-alist* nil) | |
13 | ||
14 | (defun do-lookup (name default defaultp) | |
15 | (let ((item (assoc name *dnd-alist*))) | |
16 | (cond (item (cdr item)) | |
17 | (defaultp default) | |
18 | (t (error "Missing required item ~S." name))))) | |
19 | ||
20 | (defun lookup-list (name &optional (default nil defaultp)) | |
21 | (do-lookup name default defaultp)) | |
22 | ||
23 | (defun lookup (name &optional (default nil defaultp)) | |
24 | (car (do-lookup name (list default) defaultp))) | |
25 | ||
26 | (defun hp-from-hd (&optional (hd (lookup-list :hit-dice))) | |
27 | (destructuring-bind (dice &key (plus 0) (stars 0)) hd | |
28 | (declare (ignore stars)) | |
29 | (+ (cond ((zerop dice) 0) | |
30 | ((= dice 1/8) 1) | |
31 | ((= dice 1/4) (d 2)) | |
32 | ((= dice 1/2) (d 4)) | |
33 | ((and (integerp dice) (plusp dice)) (d 8 dice)) | |
34 | (t (error "Bad hit dice ~S." hd))) | |
35 | plus))) | |
36 | ||
37 | (defun hd-table-lookup (hd table) | |
38 | (flet ((hd<= (a b) | |
39 | (let ((aa (if (consp a) (car a) a)) | |
40 | (bb (if (consp b) (car b) b))) | |
41 | (or (< aa bb) | |
42 | (and (= aa bb) | |
43 | (or (consp a) | |
44 | (not (consp b)))))))) | |
45 | (loop for ((lo . hi) . rest) in table | |
46 | when (and (hd<= lo hd) | |
47 | (hd<= hd hi)) | |
48 | return rest | |
49 | finally (return nil)))) | |
50 | ||
51 | (let ((xp-table '((( 0 . (0 +)) 5 1) | |
52 | (( 1 . 1) 10 3) | |
53 | ((( 1 +) . (1 +)) 15 4) | |
54 | (( 2 . 2) 20 5) | |
55 | ((( 2 +) . (2 +)) 25 10) | |
56 | (( 3 . 3) 30 15) | |
57 | ((( 3 +) . (3 +)) 50 25) | |
58 | (( 4 . 4) 75 50) | |
59 | ((( 4 +) . (4 +)) 125 75) | |
60 | (( 5 . 5) 175 125) | |
61 | ((( 5 +) . (5 +)) 225 175) | |
62 | (( 6 . 6) 275 225) | |
63 | ((( 6 +) . (6 +)) 350 300) | |
64 | (( 7 . 7) 450 400) | |
65 | ((( 7 +) . (7 +)) 550 475) | |
66 | (( 8 . 8) 650 550) | |
67 | ((( 8 +) . (8 +)) 775 625) | |
68 | (( 9 . 9) 900 700) | |
69 | ((( 9 +) . 10) 1000 750) | |
70 | (((10 +) . 11) 1100 800) | |
71 | (((11 +) . 12) 1250 875) | |
72 | (((12 +) . 13) 1350 950) | |
73 | (((13 +) . 14) 1500 1000) | |
74 | (((14 +) . 15) 1650 1050) | |
75 | (((15 +) . 16) 1850 1100) | |
76 | (((16 +) . 17) 2000 1150) | |
77 | (((17 +) . 18) 2125 1350) | |
78 | (((18 +) . 19) 2250 1550) | |
79 | (((19 +) . 20) 2375 1800) | |
80 | (((20 +) . 21) 2500 2000)))) | |
81 | (defun xp-from-hd (&optional (hd (lookup-list :hit-dice))) | |
82 | (destructuring-bind (dice &key (plus 0) (stars 0)) hd | |
83 | (multiple-value-bind (hd-base hd-plus) | |
84 | (cond ((zerop plus) (values dice 0)) | |
85 | ((plusp plus) (values dice 1)) | |
86 | ((minusp plus) (values (1- dice) 1))) | |
87 | (let ((result (hd-table-lookup (if (zerop hd-plus) | |
88 | hd-base | |
89 | (list hd-base '+)) | |
90 | xp-table))) | |
91 | (if result | |
92 | (destructuring-bind (base bonus) result | |
93 | (+ base (* stars bonus))) | |
94 | (let ((steps (+ hd-base -21 hd-plus))) | |
95 | (+ 2500 | |
96 | (* 250 steps) | |
97 | (* (+ 2000 (* 250 steps)) stars))))))))) | |
98 | ||
99 | (let ((thac0-table '((( 0 . 1) . 19) | |
100 | ((( 1 . +) . 2) . 18) | |
101 | ((( 2 . +) . 3) . 17) | |
102 | ((( 3 . +) . 4) . 16) | |
103 | ((( 4 . +) . 5) . 15) | |
104 | ((( 5 . +) . 6) . 14) | |
105 | ((( 6 . +) . 7) . 13) | |
106 | ((( 7 . +) . 8) . 12) | |
107 | ((( 8 . +) . 9) . 11) | |
108 | ((( 9 . +) . 11) . 10) | |
109 | (((11 . +) . 13) . 9) | |
110 | (((13 . +) . 15) . 8) | |
111 | (((15 . +) . 17) . 7) | |
112 | (((17 . +) . 19) . 6) | |
113 | (((19 . +) . 21) . 5) | |
114 | (((21 . +) . 23) . 4) | |
115 | (((23 . +) . 25) . 3) | |
116 | (((25 . +) . 27) . 2) | |
117 | (((27 . +) . 29) . 1) | |
118 | (((29 . +) . 31) . 0) | |
119 | (((31 . +) . 33) . -1) | |
120 | (((33 . +) . 35) . -2)))) | |
121 | (defun thac0-from-hd (&optional (hd (lookup-list :hit-dice))) | |
122 | (destructuring-bind (dice &key (plus 0) (stars 0)) hd | |
123 | (declare (ignore stars)) | |
124 | (multiple-value-bind (hd-base hd-plus) | |
125 | (cond ((zerop plus) (values dice 0)) | |
126 | ((plusp plus) (values dice 1)) | |
127 | ((minusp plus) (values (1- dice) 1))) | |
128 | (or (hd-table-lookup (if (zerop hd-plus) | |
129 | hd-base | |
130 | (list hd-base '+)) | |
131 | thac0-table) | |
132 | -3))))) | |
133 | ||
134 | (defparameter monster-template | |
135 | `((:hit-dice :required) | |
136 | (:thac0 :list ,#'thac0-from-hd) | |
137 | (:hit-points :list ,#'hp-from-hd) | |
138 | (:experience-points :list ,#'xp-from-hd))) | |
139 | ||
140 | (defun apply-template (def tpl) | |
141 | (flet ((run (tag func) | |
142 | (unless (assoc tag *dnd-alist*) | |
143 | (push (cons tag (funcall func)) *dnd-alist*)))) | |
144 | (loop with *dnd-alist* = def | |
145 | for (tag key . tail) in tpl do | |
146 | (case key | |
147 | (:required (lookup-list tag)) | |
148 | (:eval (run tag (car tail))) | |
149 | (:list (run tag (lambda () (list (funcall (car tail)))))) | |
150 | (t (run tag key))) | |
151 | finally (return *dnd-alist*)))) | |
152 | ||
4005b342 MW |
153 | (defun percentp (pc) (< (random 100) pc)) |
154 | ||
155 | (defun bag (&rest things) | |
156 | (loop for i in things | |
157 | when i collect i)) | |
158 | ||
159 | (defun tagged-bag (tag &rest things) | |
160 | (let ((bag (apply #'bag things))) | |
161 | (and bag (cons tag bag)))) | |
162 | ||
163 | (defun choose (&rest things) | |
164 | (let ((n 0) | |
165 | (it nil)) | |
166 | (do ((things things (cddr things))) | |
167 | ((null things) it) | |
168 | (let ((k (car things))) | |
169 | (incf n k) | |
170 | (when (and (plusp n) (< (random n) k)) | |
171 | (setf it (cadr things))))))) | |
172 | ||
173 | (defun choose-uniformly (&rest things) | |
174 | (let ((n 0) (it nil)) | |
175 | (do ((things things (cdr things))) | |
176 | ((null things) it) | |
177 | (incf n) | |
178 | (when (< (random n) 1) | |
179 | (setf it (car things)))))) | |
180 | ||
181 | (defmacro pick (&rest clauses) | |
182 | `(funcall (choose ,@(loop for (n . clause) in clauses | |
183 | collect n | |
184 | collect `(lambda () ,@clause))))) | |
185 | ||
186 | (defconstant druid-spells | |
187 | #((detect-danger faerie-fire locate predict-weather) | |
188 | (heat-metal obscure produce-fire warp-wood) | |
189 | (call-lightning hold-animal protection-from-poison water-breathing) | |
190 | (control-temperature-10-ft-radius plant-door protection-from-lightning | |
191 | summon-animals) | |
192 | (anti-plant-shell control-winds dissolve pass-plant) | |
193 | (anti-animal-shell summon-weather transport-through-plants turn-wood) | |
194 | (creeping-doom metal-to-wood summon-elemental weather-control))) | |
195 | ||
196 | (defconstant cleric-spells | |
197 | #((cure-light-wounds detect-evil detect-magic light protection-from-evil | |
198 | purify-food-and-water remove-fear resist-cold) | |
199 | (bless find-traps hold-person resist-fire silence-15-ft-radius | |
200 | slow-poison snake-charm speak-with-animal) | |
201 | (continual-light cure-blindness cure-disease growth-of-animals | |
202 | locate-object remove-curse speak-with-the-dead striking) | |
203 | (animate-dead create-water cure-serious-wounds dispel-magic | |
204 | neutralize-poison protection-from-evil-10-ft-radius speak-with-plants | |
205 | sticks-to-snakes) | |
206 | (commune create-food cure-critical-wounds dispel-evil insect-plague quest | |
207 | raise-dead truesight) | |
208 | (aerial-servant animate-objects barrier create-normal-animals cureall | |
209 | find-the-path speak-with-monsters word-of-recall) | |
210 | (earthquake holy-word raise-dead-fully restore survival travel wish | |
211 | wizardry))) | |
212 | ||
213 | (defconstant magic-user-spells | |
214 | #((analyse charm-person detect-magic floating-disc hold-portal light | |
215 | magic-missile protection-from-evil read-languages read-magic shield | |
216 | sleep ventriloquism) | |
217 | (continual-light detect-evil detect-invisible entangle esp invisibility | |
218 | knock levitate locate-object mirror-image phantasmal-force web | |
219 | wizard-lock) | |
220 | (clairvoyance create-air dispel-magic fire-ball fly haste hold-person | |
221 | infravision invisibility-10-ft-radius lightning-bolt | |
222 | protection-from-evil-10-ft-radius protection-from-normal-missiles | |
223 | water-breathing) | |
224 | (charm-monster clothform confusion dimension-door growth-of-plants | |
225 | hallucinatory-terrain ice-storm/wall massmorph polymorph-others | |
226 | polymorph-self remove-curse wall-of-fire wizard-eye) | |
227 | (animate-dead cloudkill conjure-elemental contact-outer-plane dissolve | |
228 | feeblemind hold-monster magic-jar pass-wall telekinesis teleport | |
229 | wall-of-stone woodform) | |
230 | (anti-magic-shell death-spell disintegrate geas invisible-stalker | |
231 | lower-water move-earth projected-image reincarnation stone-to-flesh | |
232 | stoneform wall-of-iron weather-control) | |
233 | (charm-plant create-normal-monsters delayed-blast-fire-ball ironform lore | |
234 | magic-door mass-invisibility power-word-stun reverse-gravity statue | |
235 | summon-object sword teleport-any-object) | |
236 | (clone create-magical-monsters dance explosive-cloud force-field | |
237 | mass-charm mind-barrier permanence polymorph-any-object power-word-blind | |
238 | steelform symbol travel) | |
239 | (contingency create-any-monster gate heal immunity maze meteor-swarm | |
240 | power-word-kill prismatic-wall shapechange survival timestop wish))) | |
241 | ||
242 | (defun spell-caster-type () | |
243 | (choose 25 :cleric 5 :druid 70 :magic-user)) | |
244 | ||
245 | (defun random-spell (&optional (caster (spell-caster-type)) | |
246 | (level (ecase caster | |
247 | ((:magic-user) (choose 28 1 | |
248 | 21 2 | |
249 | 15 3 | |
250 | 11 4 | |
251 | 9 5 | |
252 | 7 6 | |
253 | 5 7 | |
254 | 3 8 | |
255 | 1 9)) | |
256 | ((:cleric :druid) (choose 34 1 | |
257 | 24 2 | |
258 | 18 3 | |
259 | 12 4 | |
260 | 7 5 | |
261 | 4 6 | |
262 | 1 7))))) | |
263 | (let ((list (aref (ecase caster | |
264 | ((:magic-user) magic-user-spells) | |
265 | ((:cleric) cleric-spells) | |
266 | ((:druid) druid-spells)) | |
267 | level))) | |
268 | (values (elt list (random (length list))) | |
269 | caster | |
270 | level))) | |
271 | ||
272 | (defun symbol-match-p (form sym) | |
273 | (cond ((eq form t) t) | |
274 | ((eq form nil) nil) | |
275 | ((eq form sym) t) | |
276 | ((atom form) nil) | |
277 | (t (ecase (car form) | |
278 | ((and) (every (lambda (f) (symbol-match-p f sym)) (cdr form))) | |
279 | ((or) (some (lambda (f) (symbol-match-p f sym)) (cdr form))) | |
280 | ((not) (not (symbol-match-p (cadr form) sym))))))) | |
281 | ||
282 | (defun choose-distinct-items (n seq) | |
283 | (let* ((copy (subseq (coerce seq 'vector) 0)) | |
284 | (len (length copy)) | |
285 | (list nil)) | |
286 | (dotimes (i n (sort list #'string<)) | |
287 | (let ((j (random len))) | |
288 | (push (aref copy j) list) | |
289 | (decf len) | |
290 | (setf (aref copy j) (aref copy len)))))) | |
291 | ||
292 | (defun magic-item (form) | |
293 | (labels ((potion (&key recursivep) | |
294 | (pick (2 `(:potion agility)) | |
295 | (1 `(:potion animal-control)) | |
296 | (3 `(:potion antidote)) | |
297 | (2 `(:potion blending)) | |
298 | (2 `(:potion bug-repellent)) | |
299 | (2 `(:potion clairaudience)) | |
300 | (2 `(:potion clairvoyance)) | |
301 | (2 `(:potion climbing)) | |
302 | (2 `(:potion defence :bonus ,(choose 3 1 | |
303 | 2 2 | |
304 | 2 3 | |
305 | 2 4 | |
306 | 1 5))) | |
307 | ((if recursivep 0 4) | |
308 | `(:potion delusion | |
309 | :fakes ,@(cdr (potion :recursivep t)))) | |
310 | (2 `(:potion diminution)) | |
311 | (1 `(:potion ,(choose 35 'white-dragon-control | |
312 | 15 'crystal-dragon-control | |
313 | 35 'black-dragon-control | |
314 | 15 'onyx-dragon-control | |
315 | 28 'green-dragon-control | |
316 | 12 'jade-dragon-control | |
317 | 21 'blue-dragon-control | |
318 | 9 'sapphire-dragon-control | |
319 | 14 'red-dragon-control | |
320 | 6 'ruby-dragon-control | |
321 | 7 'gold-dragon-control | |
322 | 3 'amber-dragon-control))) | |
323 | (2 `(:potion dreamspeech)) | |
324 | (1 `(:potion elasicity)) | |
325 | (2 `(:potion ,(choose-uniformly 'air-form | |
326 | 'water-form | |
327 | 'earth-form | |
328 | 'fire-form))) | |
329 | (2 `(:potion esp)) | |
330 | (1 `(:potion ethereality)) | |
331 | (3 `(:potion fire-resistance)) | |
332 | (3 `(:potion flying)) | |
333 | (2 `(:potion fortitude)) | |
334 | (1 `(:potion freedom)) | |
335 | (3 `(:potion gaseous-form)) | |
336 | (1 `(:potion ,(choose 5 'hill-giant-control | |
337 | 5 'stone-giant-control | |
338 | 4 'frost-giant-control | |
339 | 2 'fire-giant-control | |
340 | 1 'mountain-giant-control | |
341 | 1 'sea-giant-control | |
342 | 1 'cloud-giant-control | |
343 | 1 'storm-giant-control))) | |
344 | (3 `(:potion giant-strength)) | |
345 | (2 `(:potion growth)) | |
346 | (6 `(:potion healing)) | |
347 | (3 `(:potion heroism)) | |
348 | (1 `(:potion human-control)) | |
349 | (3 `(:potion invisibility)) | |
350 | (2 `(:potion invulnerability)) | |
351 | (2 `(:potion levitation)) | |
352 | (2 `(:potion longevity)) | |
353 | (1 `(:potion luck)) | |
354 | (1 `(:potion merging)) | |
355 | (2 `(:potion plant-control)) | |
356 | (3 `(:potion poison)) | |
357 | (3 `(:potion polymorph-self)) | |
358 | (2 `(:potion sight)) | |
359 | (2 `(:potion speech)) | |
360 | (4 `(:potion speed)) | |
361 | (2 `(:potion strength)) | |
362 | (3 `(:potion super-healing)) | |
363 | (3 `(:potion swimming)) | |
364 | (1 `(:potion treasure-finding)) | |
365 | (1 `(:potion undead-control)) | |
366 | (2 `(:potion water-breathing)))) | |
367 | (scroll () | |
368 | (pick (3 `(:scroll communication)) | |
369 | (2 `(:scroll creation)) | |
370 | (8 `(:scroll curse)) | |
371 | (1 (multiple-value-bind | |
372 | (spell caster level) | |
373 | (random-spell) | |
374 | (declare (ignore level)) | |
375 | `(:scroll delay :caster ,caster :spells (,spell)))) | |
376 | (3 `(:scroll equipment | |
377 | :items ,(choose-distinct-items 6 | |
378 | '(grappling-hook | |
379 | hammer | |
380 | iron-spikes | |
381 | lantern | |
382 | mirror | |
383 | wooden-pole | |
384 | rope | |
385 | saddle | |
386 | backpack | |
387 | saddle-bags | |
388 | stakes-and-mallet | |
389 | wolfsbane)))) | |
390 | (2 `(:scroll illumination)) | |
391 | (2 `(:scroll mages)) | |
392 | (4 `(:map normal-treasure)) | |
393 | (3 `(:map magical-treasure)) | |
394 | (2 `(:map combined-treasure)) | |
395 | (1 `(:map special-treasure)) | |
396 | (3 `(:scroll mapping)) | |
397 | (2 `(:scroll portals)) | |
398 | (6 `(:scroll protection-from-elementals)) | |
399 | (8 `(:scroll protection-from-lycanthropes)) | |
400 | (4 `(:scroll protection-from-magic)) | |
401 | (7 `(:scroll protection-from-undead)) | |
402 | (2 `(:scroll questioning)) | |
403 | (1 (multiple-value-bind | |
404 | (spell caster level) | |
405 | (random-spell) | |
406 | `(:scroll repetition | |
407 | :caster ,caster | |
408 | :level ,level | |
409 | :spells (,spell)))) | |
410 | (2 `(:scroll seeing)) | |
411 | (2 `(:scroll shelter)) | |
412 | (3 `(:scroll spell-catching :max-level ,(choose 4 1 | |
413 | 3 2 | |
414 | 2 3 | |
415 | 1 8))) | |
416 | (25 (let ((caster (spell-caster-type)) | |
417 | (spells (choose 50 1 33 2 17 3))) | |
418 | `(:scroll spell | |
419 | :caster ,caster | |
420 | :spells ,(loop repeat spells | |
421 | collect (random-spell caster))))) | |
422 | (2 `(:scroll trapping)) | |
423 | (2 `(:scroll truth)))) | |
424 | (wand-charges () (d 10 3)) | |
425 | (staff-charges () (d 20 2)) | |
426 | (wandlike () | |
427 | (pick (5 `(:wand cold :charges ,(wand-charges))) | |
428 | (5 `(:wand enemy-detection :charges ,(wand-charges))) | |
429 | (4 `(:wand fear :charges ,(wand-charges))) | |
430 | (5 `(:wand fireballs :charges ,(wand-charges))) | |
431 | (4 `(:wand illusion :charges ,(wand-charges))) | |
432 | (5 `(:wand lightning-bolts :charges ,(wand-charges))) | |
433 | (5 `(:wand magic-detection :charges ,(wand-charges))) | |
434 | (5 `(:wand metal-detection :charges ,(wand-charges))) | |
435 | (4 `(:wand negation :charges ,(wand-charges))) | |
436 | (5 `(:wand paralysation :charges ,(wand-charges))) | |
437 | (5 `(:wand polymorphing :charges ,(wand-charges))) | |
438 | (4 `(:wand secret-door-detection | |
439 | :charges ,(wand-charges))) | |
440 | (4 `(:wand trap-detection :charges ,(wand-charges))) | |
441 | (1 `(:staff commanding :charges nil)) | |
442 | (2 `(:staff dispelling :charges ,(staff-charges))) | |
443 | (3 `(:staff druids :charges ,(staff-charges))) | |
444 | (3 `(:staff ,(choose 19 'air | |
445 | 19 'earth | |
446 | 19 'fire | |
447 | 19 'water | |
448 | 6 'air-and-water | |
449 | 6 'earth-and-fire | |
450 | 2 'elemental-power) | |
451 | :charges ,(staff-charges))) | |
452 | (2 `(:staff harming :charges ,(staff-charges))) | |
453 | (7 `(:staff healing :charges ,(staff-charges))) | |
454 | (1 `(:staff power :charges ,(staff-charges))) | |
455 | (3 `(:staff snake :charges ,(staff-charges))) | |
456 | (3 `(:staff striking :charges ,(staff-charges))) | |
457 | (2 `(:staff withering :charges ,(staff-charges))) | |
458 | (1 `(:staff wizardry :charges ,(staff-charges))) | |
459 | (2 `(:rod cancellation)) | |
460 | (1 `(:rod dominion)) | |
461 | (1 `(:rod health)) | |
462 | (2 `(:rod inertia)) | |
463 | (1 `(:rod parrying)) | |
464 | (1 `(:rod victory)) | |
465 | (3 `(:rod weaponry)) | |
466 | (1 `(:rod wyrm :colour ,(choose 5 'gold | |
467 | 3 'blue | |
468 | 2 'black))))) | |
469 | (ring () | |
470 | (pick (2 `(:ring animal-control)) | |
471 | (6 `(:ring delusion)) | |
472 | (1 `(:ring djinni-summoning)) | |
473 | (4 `(:ring ear)) | |
474 | (4 `(:ring ,(choose 19 'air-adaptation | |
475 | 19 'earth-adaptation | |
476 | 19 'fire-adaptation | |
477 | 19 'water-adaptation | |
478 | 6 'air-and-water-adaptation | |
479 | 6 'earth-and-fire-adaptation | |
480 | 2 'elemental-adaptation))) | |
481 | (6 `(:ring fire-resistance)) | |
482 | (3 `(:ring holiness)) | |
483 | (1 `(:ring human-control)) | |
484 | (5 `(:ring invisibility)) | |
485 | (3 `(:ring life-protection :charges ,(d 6))) | |
486 | (3 `(:ring memory)) | |
487 | (2 `(:ring plant-control)) | |
488 | (1 `(:ring protection :bonus 1 :radius 5)) | |
489 | (10 `(:ring protection :bonus ,(choose 4 1 | |
490 | 3 2 | |
491 | 2 3 | |
492 | 1 4))) | |
493 | (4 `(:ring quickness)) | |
494 | (1 `(:ring regeneration)) | |
495 | (3 `(:ring remedies)) | |
496 | (2 `(:ring safety :charges ,(d 4))) | |
497 | (3 `(:ring seeing)) | |
498 | (3 `(:ring spell-eating)) | |
499 | (2 (let* ((caster (spell-caster-type)) | |
500 | (spells (loop repeat (d 6) | |
501 | collect (random-spell caster)))) | |
502 | `(:ring spell-storing | |
503 | :caster ,caster | |
504 | :spells ,(remove-duplicates (sort spells | |
505 | #'string<))))) | |
506 | (2 `(:ring spell-turning)) | |
507 | (4 `(:ring survival :charges ,(+ 100 (d 100)))) | |
508 | (2 `(:ring telekinesis)) | |
509 | (4 `(:ring truth)) | |
510 | (3 `(:ring truthfulness)) | |
511 | (2 `(:ring truthlessness)) | |
512 | (5 `(:ring water-walking)) | |
513 | (5 `(:ring weakness)) | |
514 | (2 `(:ring wishes :charges ,(choose 4 1 | |
515 | 3 2 | |
516 | 2 3 | |
517 | 1 4))) | |
518 | (2 `(:ring x-ray-vision)))) | |
519 | (misc-item () | |
520 | (pick (2 `(:amulet protection-from-crystal-balls-and-esp)) | |
521 | (2 `(:bag devouring)) | |
522 | (5 `(:bag holding)) | |
523 | (3 `(:boat undersea)) | |
524 | (2 `(:boots levitation)) | |
525 | (3 `(:boots speed)) | |
526 | (2 `(:boots travelling-and-leaping)) | |
527 | (1 `(:bowl commanding-water-elementals)) | |
528 | (1 `(:brazier commanding-fire-elementals)) | |
529 | (2 `(:broom flying)) | |
530 | (1 `(:censer controlling-air-elementals)) | |
531 | (3 `(:chime time)) | |
532 | (2 `(:crystal-ball normal)) | |
533 | (1 `(:crystal-ball clairaudience)) | |
534 | (1 `(:crystal-ball esp)) | |
535 | (2 `(:cloak displacer)) | |
536 | (1 `(:drums panic)) | |
537 | (1 `(:bottle efreeti)) | |
538 | (3 `(:egg ,(choose-uniformly 'rock-baboon | |
539 | 'giant-bat | |
540 | 'black-bear | |
541 | 'grizzly-bear | |
542 | 'boar | |
543 | 'mountain-lion | |
544 | 'panther | |
545 | 'giant-ferret | |
546 | 'gecko | |
547 | 'draco | |
548 | 'racer-snake | |
549 | 'wolf))) | |
550 | (2 `(:boots elven)) | |
551 | (2 `(:cloak elven)) | |
552 | (1 `(:carpet flying)) | |
553 | (2 `(:gauntlets ogre-power)) | |
554 | (2 `(:girdle giant-strength)) | |
555 | (2 `(:helm ,(choose-uniformly 'lawful-alignment | |
556 | 'neutral-alignment | |
557 | 'chaotic-alignment))) | |
558 | (2 `(:helm reading)) | |
559 | (1 `(:helm telepathy)) | |
560 | (1 `(:helm teleportation)) | |
561 | (1 `(:horn blasting)) | |
562 | (2 `(:lamp hurricane)) | |
563 | (3 `(:lamp long-burning)) | |
564 | (2 `(:medallion esp-30-ft-range)) | |
565 | (1 `(:medallion esp-90-ft-range)) | |
566 | (1 `(:mirror life-trapping)) ;;; fixme include contents | |
567 | (3 `(:muzzle training)) | |
568 | (2 `(:nail finger)) | |
569 | (3 `(:nail pointing)) | |
570 | (5 `(:ointment ,(choose-uniformly 'blessing | |
571 | 'healing | |
572 | 'poison | |
573 | 'scarring | |
574 | 'soothing | |
575 | 'tanning))) | |
576 | (3 `(:pouch security)) | |
577 | (3 `(:quill copying)) | |
578 | (4 `(:rope climbing)) | |
579 | (2 `(:scarab protection :charges ,(d 6 2))) | |
580 | (3 `(:slate identification)) | |
581 | (1 `(:stone controlling-earth-elementals)) | |
582 | (2 `(:talisman ,(choose-uniformly 'air-travel | |
583 | 'earth-travel | |
584 | 'fire-travel | |
585 | 'water-travel | |
586 | 'elemental-travel))) | |
587 | (3 `(:wheel floating)) | |
588 | (1 `(:wheel fortune)) | |
589 | (2 `(:wheel square)))) | |
590 | (weapon-bonus (class) | |
591 | (loop for bonus from 1 | |
592 | for roll = (random 100) then (- roll item) | |
593 | for item in (ecase class | |
594 | ((a) '(40 27 17 10 6)) | |
595 | ((b) '(50 24 14 8 4)) | |
596 | ((c) '(60 21 11 6 2)) | |
597 | ((d) '(70 18 8 3 1))) | |
598 | when (< roll item) return bonus)) | |
599 | (armour-size () | |
600 | (choose 68 'human | |
601 | 13 'dwarf | |
602 | 10 'elf | |
603 | 7 'halfling | |
604 | 2 'giant)) | |
605 | (armour-piece (class) | |
606 | (let* ((bonus (weapon-bonus class)) | |
607 | (power (and (percentp (* 5 (1+ bonus))) | |
608 | (pick (7 `(absorption)) | |
609 | (10 `(charm)) | |
610 | (15 `(cure-wounds)) | |
611 | (10 `(electricity)) | |
612 | (5 `(energy-drain)) | |
613 | (3 `(ethereality)) | |
614 | (10 `(fly)) | |
615 | (6 `(gaseous-form)) | |
616 | (9 `(haste)) | |
617 | (10 `(invisibility)) | |
618 | (8 `(reflection)) | |
619 | (7 `(remove-curse :charges ,(d 3)))))) | |
620 | (cursedp (if (and power (eq (car power) 'remove-curse)) | |
621 | nil | |
622 | (zerop (random 8))))) | |
623 | `(:bonus ,bonus | |
624 | ,@(and power (cons :power power)) | |
625 | :size ,(armour-size) | |
626 | ,@(and cursedp `(:cursed t))))) | |
627 | (armour () | |
628 | (pick (10 `((:leather ,@(armour-piece 'd)))) | |
629 | ( 7 `((:scale-mail ,@(armour-piece 'd)))) | |
630 | (13 `((:chain-mail ,@(armour-piece 'c)))) | |
631 | ( 9 `((:banded-mail ,@(armour-piece 'd)))) | |
632 | (11 `((:plate-mail ,@(armour-piece 'b)))) | |
633 | ( 5 `((:suit-armour ,@(armour-piece 'b)))) | |
634 | (20 `((:shield ,@(armour-piece 'a)))) | |
635 | ( 2 `((:scale-mail ,@(armour-piece 'd)) | |
636 | (:shield ,@(armour-piece 'a)))) | |
637 | ( 8 `((:chain-mail ,@(armour-piece 'c)) | |
638 | (:shield ,@(armour-piece 'a)))) | |
639 | ( 5 `((:banded-mail ,@(armour-piece 'd)) | |
640 | (:shield ,@(armour-piece 'a)))) | |
641 | (10 `((:plate-mail ,@(armour-piece 'b)) | |
642 | (:shield ,@(armour-piece 'a)))))) | |
643 | (opponent () | |
644 | (choose 6 'bugs | |
645 | 3 'constructs | |
646 | 6 'dragonkind | |
647 | 9 'enchanted-monsters | |
648 | 12 'giantkind | |
649 | 12 'lycanthropes | |
650 | 4 'planar-monsters | |
651 | 6 'regenerating-monsters | |
652 | 9 'reptiles-and-dinosaurs | |
653 | 3 'spell-immune-monsters | |
654 | 6 'spellcasters | |
655 | 12 'undead | |
656 | 6 'water-breathing-monsters | |
657 | 6 'weapon-using-monsters)) | |
658 | (weapon-talent (&key missilep) | |
659 | (pick (5 `(breathing)) | |
660 | (7 `(charming)) | |
661 | (4 `(deceiving)) | |
662 | ((if missilep 0 7) `(defending)) | |
663 | (2 `(deflecting)) | |
664 | (2 `(draining :charges ,(+ 4 (d 4)))) | |
665 | (5 `(extinguishing)) | |
666 | (6 `(finding)) | |
667 | (5 `(flaming)) | |
668 | (3 `(flying)) | |
669 | (8 `(healing)) | |
670 | (5 `(hiding)) | |
671 | (6 `(holding)) | |
672 | (8 `(lightning)) | |
673 | (6 `(silencing)) | |
674 | (2 `(slicing)) | |
675 | (4 `(slowing)) | |
676 | (4 `(speeding)) | |
677 | (5 `(translating)) | |
678 | (5 `(watching)) | |
679 | (1 `(wishing :charges ,(d 3))))) | |
680 | (weapon-modifier (bonus &rest keys &key &allow-other-keys) | |
681 | (and (percentp (aref #(40 30 20 15 10) (1- bonus))) | |
682 | (pick (33 `(:extra (,(+ bonus 1) :against ,(opponent)))) | |
683 | (24 `(:extra (,(+ bonus 2) :against ,(opponent)))) | |
684 | (16 `(:extra (,(+ bonus 3) :against ,(opponent)))) | |
685 | (9 `(:extra (,(+ bonus 4) :against ,(opponent)))) | |
686 | (3 `(:extra (,(+ bonus 5) :against ,(opponent)))) | |
687 | (15 `(:talent ,@(apply #'weapon-talent keys)))))) | |
688 | (sword-modifier (bonus &rest keys &key &allow-other-keys) | |
689 | (and (percentp (aref #(40 30 25 20 15) (1- bonus))) | |
690 | (pick (29 `(:extra (,(+ bonus 1) :against ,(opponent)))) | |
691 | (21 `(:extra (,(+ bonus 2) :against ,(opponent)))) | |
692 | (14 `(:extra (,(+ bonus 3) :against ,(opponent)))) | |
693 | (8 `(:extra (,(+ bonus 4) :against ,(opponent)))) | |
694 | (3 `(:extra (,(+ bonus 5) :against ,(opponent)))) | |
695 | (25 `(:talent ,@(apply #'weapon-talent keys)))))) | |
696 | (missile () | |
697 | (multiple-value-bind | |
698 | (item class) | |
699 | (pick (37 (values :arrow 'a)) | |
700 | (22 (values :quarrel 'a)) | |
701 | (11 (values :sling-stone 'a)) | |
702 | (2 (values :blowgun 'd)) | |
703 | (8 (values :long-bow 'd)) | |
704 | (5 (values :short-bow 'd)) | |
705 | (2 (values :heavy-crossbow 'd)) | |
706 | (5 (values :light-crossbow 'd)) | |
707 | (8 (values :sling 'd))) | |
708 | (ecase class | |
709 | ((a) (let* ((bonus (weapon-bonus 'a)) | |
710 | (cursedp (zerop (random 10))) | |
711 | (talent (and (percentp (* 5 (- 7 bonus))) | |
712 | (choose 4 'biting | |
713 | 5 'blinking | |
714 | 5 'charming | |
715 | 7 'climbing | |
716 | 10 'curing | |
717 | 3 'disarming | |
718 | 4 'dispelling | |
719 | 7 'flying | |
720 | 7 'lightning | |
721 | 5 'penetrating | |
722 | 4 'refilling | |
723 | 6 'screaming | |
724 | 5 'seeking | |
725 | 4 'sinking | |
726 | 2 'slaying | |
727 | 7 'speaking | |
728 | 4 'stunning | |
729 | 2 'teleporting | |
730 | 5 'transporting | |
731 | 4 'wounding))) | |
732 | (number (ecase bonus | |
733 | ((1) (d 10 2)) | |
734 | ((2) (d 8 2)) | |
735 | ((3) (d 6 2)) | |
736 | ((4) (d 4 2)) | |
737 | ((5) (+ (d 4) 1))))) | |
738 | `(,item :bonus ,bonus | |
739 | ,@(and talent `(:talent ,talent)) | |
740 | :number ,number | |
741 | ,@(and cursedp `(:cursed t))))) | |
742 | ((d) (let* ((bonus (weapon-bonus 'd)) | |
743 | (cursedp (zerop (random 10))) | |
744 | (modifier (weapon-modifier bonus :missilep t)) | |
745 | (range (ecase (+ bonus (d 4)) | |
746 | ((2 3 4) nil) | |
747 | ((5 6 7) 1.5) | |
748 | ((8 9) 2)))) | |
749 | `(,item :bonus ,bonus ,@modifier | |
750 | ,@(and range `(:range ,range)) | |
751 | ,@(and cursedp `(:cursed t)))))))) | |
752 | (weapon-intelligence () | |
753 | (multiple-value-bind | |
754 | (int langs prim read-magic-p extra) | |
755 | (pick (79 (values nil 0 0 nil 0)) | |
756 | (6 (values 7 0 1 nil 0)) | |
757 | (5 (values 8 0 2 nil 0)) | |
758 | (4 (values 9 0 3 nil 0)) | |
759 | (3 (values 10 (d 3) 3 nil 0)) | |
760 | (2 (values 11 (d 6) 3 t 0)) | |
761 | (1 (values 12 (d 4 2) 3 t 1))) | |
762 | (and int | |
763 | (let ((powers nil) | |
764 | (healing nil) | |
765 | (damage nil) | |
766 | (checklist nil)) | |
767 | (macrolet ((power-check (&rest forms) | |
768 | `(pick ,@(loop for (tag n . form) in forms | |
769 | if tag | |
770 | collect | |
771 | `((if (member ',tag | |
772 | checklist) | |
773 | 0 | |
774 | ,n) | |
775 | (push ',tag checklist) | |
776 | ,@(or form | |
777 | `((push ',tag | |
778 | powers)))) | |
779 | else | |
780 | collect `(,n ,@form))))) | |
781 | (labels ((primary-power () | |
782 | (power-check | |
783 | (detect-evil 10) | |
784 | (detect-gems 5) | |
785 | (detect-magic 10) | |
786 | (detect-metal 10) | |
787 | (detect-shifting-walls-and-rooms 15) | |
788 | (detect-sloping-passages 15) | |
789 | (find-secret-doors 10) | |
790 | (find-traps 10) | |
791 | (see-invisible 10) | |
792 | (:one-extra 4 | |
793 | (extraordinary-power)) | |
794 | (:two-primary 1 | |
795 | (primary-power) | |
796 | (primary-power)))) | |
797 | (extraordinary-power () | |
798 | (power-check | |
799 | (clairaudience 10) | |
800 | (clairvoyance 10) | |
801 | (esp 10) | |
802 | (nil 5 | |
803 | (setf damage (if damage | |
804 | (1+ damage) | |
805 | 5))) | |
806 | (flying 5) | |
807 | (nil 5 | |
808 | (setf healing (+ (or healing 0) 6))) | |
809 | (illusion 9) | |
810 | (levitation 5) | |
811 | (telekinesis 10) | |
812 | (telepathy 10) | |
813 | (teleportation 9) | |
814 | (x-ray-vision 9) | |
815 | (:two-three-extra 2 | |
816 | (extraordinary-power) | |
817 | (extraordinary-power)) | |
818 | (:two-three-extra 1 | |
819 | (extraordinary-power) | |
820 | (extraordinary-power) | |
821 | (extraordinary-power))))) | |
822 | (dotimes (i prim) (primary-power)) | |
823 | (dotimes (i extra) (extraordinary-power)))) | |
824 | (when damage | |
825 | (push `(extra-damage ,damage) powers)) | |
826 | (when healing | |
827 | (push `(healing ,healing) powers)) | |
828 | `(:intelligence ,int | |
829 | :ego ,(d 12) | |
830 | :languages ,langs | |
831 | ,@(and read-magic-p `(:read-magic t)) | |
832 | :powers ,powers))))) | |
833 | (sword () | |
834 | (multiple-value-bind | |
835 | (type class) | |
836 | (pick (65 (values :normal-sword 'c)) | |
837 | (19 (values :short-sword 'c)) | |
838 | (8 (values :two-handed-sword 'd)) | |
839 | (8 (values :bastard-sword 'd))) | |
840 | (let* ((bonus (weapon-bonus class)) | |
841 | (cursedp (zerop (random 10))) | |
842 | (modifier (sword-modifier bonus)) | |
843 | (intel (weapon-intelligence))) | |
844 | `(,type :bonus ,bonus | |
845 | ,@modifier | |
846 | ,@intel | |
847 | ,@(and cursedp `(:cursed t)))))) | |
848 | (weapon () | |
849 | (multiple-value-bind | |
850 | (type returnsp class) | |
851 | (pick (7 (values :battle-axe nil 'd)) | |
852 | (8 (values :hand-axe (choose 3 nil 1 t) 'b)) | |
853 | (3 (values :blackjack nil 'c)) | |
854 | (3 (values :bola (choose 2 nil 1 t) 'b)) | |
855 | (5 (values :club nil 'c)) | |
856 | (14 (values :dagger (choose 11 nil 3 t) 'b)) | |
857 | (4 (values :one-handed-flail nil 'c)) | |
858 | (2 (values :two-handed-flail nil 'd)) | |
859 | (3 (values :halberd nil 'd)) | |
860 | (8 (values :war-hammer nil 'c)) | |
861 | (4 (values :javelin (choose 3 nil 1 t) 'b)) | |
862 | (4 (values :lance nil 'd)) | |
863 | (7 (values :mace nil 'c)) | |
864 | (5 (values :morning-star nil 'c)) | |
865 | (3 (values :net (choose 2 nil 1 t) 'b)) | |
866 | (3 (values :pike nil 'd)) | |
867 | (2 (values :pole-axe nil 'd)) | |
868 | (12 (values :spear (choose 3 nil 1 t) 'b)) | |
869 | (3 (values :whip nil 'c))) | |
870 | (let* ((bonus (weapon-bonus class)) | |
871 | (cursedp (zerop (random 10))) | |
872 | (modifier (sword-modifier bonus)) | |
873 | (intel (and (percentp 40) | |
874 | (weapon-intelligence)))) | |
875 | `(,type | |
876 | ,@(and returnsp `(:returning t)) | |
877 | :bonus ,bonus | |
878 | ,@modifier | |
879 | ,@intel | |
880 | ,@(and cursedp `(:cursed t))))))) | |
881 | (pick ((if (symbol-match-p form :potion) 25 0) (list (potion))) | |
882 | ((if (symbol-match-p form :scroll) 12 0) (list (scroll))) | |
883 | ((if (symbol-match-p form :wandlike) 9 0) (list (wandlike))) | |
884 | ((if (symbol-match-p form :ring) 6 0) (list (ring))) | |
885 | ((if (symbol-match-p form :misc) 10 0) (list (misc-item))) | |
886 | ((if (symbol-match-p form :armour) 10 0) (armour)) | |
887 | ((if (symbol-match-p form :missile) 11 0) (list (missile))) | |
888 | ((if (symbol-match-p form :sword) 9 0) (list (sword))) | |
889 | ((if (symbol-match-p form :weapon) 8 0) (list (weapon)))))) | |
890 | ||
891 | (defun treasure-type (type-code) | |
892 | (labels ((common-fur-type () | |
893 | (choose-uniformly 'beaver | |
894 | 'fox | |
895 | 'marten | |
896 | 'seal)) | |
897 | (rare-fur-type () | |
898 | (choose-uniformly 'ermine | |
899 | 'mink | |
900 | 'sable)) | |
901 | (special (n) | |
902 | (tagged-bag | |
903 | :special | |
904 | (loop repeat n | |
905 | collect | |
906 | (pick (10 `(:kind book | |
907 | :value ,(* 10 (d 100)) | |
908 | :encumbrance ,(d 100))) | |
909 | (2 `(:kind pelt | |
910 | :animal ,(common-fur-type) | |
911 | :value ,(d 4) | |
912 | :encumbrance ,(* 10 (d 6)))) | |
913 | (5 `(:kind cape | |
914 | :animal ,(common-fur-type) | |
915 | :value ,(* 100 (d 6)) | |
916 | :encumbrance ,(* 10 (+ 4 (d 8))))) | |
917 | (3 `(:kind coat | |
918 | :animal ,(common-fur-type) | |
919 | :value ,(* 100 (d 4 3)) | |
920 | :encumbrance ,(* 10 (+ 8 (d 6 2))))) | |
921 | (2 `(:kind pelt | |
922 | :animal ,(rare-fur-type) | |
923 | :value ,(d 6 2) | |
924 | :encumbrance ,(* 10 (d 6)))) | |
925 | (5 `(:kind cape | |
926 | :animal ,(rare-fur-type) | |
927 | :value ,(* 100 (d 6 4)) | |
928 | :encumbrance ,(* 10 (+ 4 (d 8))))) | |
929 | (3 `(:kind coat | |
930 | :animal ,(rare-fur-type) | |
931 | :value ,(* 1000 (d 4)) | |
932 | :encumbrance ,(* 10 (+ 8 (d 6 2))))) | |
933 | (5 `(:kind incense | |
934 | :value ,(d 6 5) | |
935 | :encumbrance 1 | |
936 | :quantity ,(d 4 2))) | |
937 | (5 `(:kind perfume | |
938 | :value ,(* 10 (+ 5 (d 10))) | |
939 | :encumbrance 1 | |
940 | :quantity ,(d 3 2))) | |
941 | (5 (let ((w (d 6)) (h (d 2))) | |
942 | `(:kind ,(choose-uniformly 'rug | |
943 | 'tapestry) | |
944 | :value ,(* w h (d 10 2)) | |
945 | :encumbrance ,(* 100 w h (d 6)) | |
946 | :size (* ,w ,h)))) | |
947 | (10 (let ((w (d 8)) (h (d 2))) | |
948 | `(:kind silk | |
949 | :value ,(* w h (d 8)) | |
950 | :encumbrance ,(* 10 w h (d 6)) | |
951 | :size (* ,w ,h)))) | |
952 | (10 `(:kind animal-skin | |
953 | :value ,(d 10) | |
954 | :encumbrance ,(* 10 (d 4 5)))) | |
955 | (10 `(:kind monster-skin | |
956 | :value ,(* 100 (d 10)) | |
957 | :encumbrance ,(* 50 (d 100)))) | |
958 | (5 (let ((enc (d 100))) | |
959 | `(:kind spice | |
960 | :value ,(* enc (d 4 4)) | |
961 | :encumbrance ,enc))) | |
962 | (5 `(:kind statuette | |
963 | :value ,(* 100 (d 10)) | |
964 | :encumbrance ,(d 100))) | |
965 | (5 `(:wine | |
966 | :value ,(d 6) | |
967 | :encumbrance ,(* 10 (+ 3 (d 6))) | |
968 | :bottles ,(d 12))))))) | |
969 | (gem-type (&key (min-value 0) recursivep) | |
970 | (pick ((if (<= min-value 10) 3 0) | |
971 | (values 10 (choose-uniformly 'agate | |
972 | 'quartz | |
973 | 'turquoise))) | |
974 | ((if (<= min-value 50) 7 0) | |
975 | (values 50 (choose-uniformly 'crystal | |
976 | 'jasper | |
977 | 'onyx))) | |
978 | ((if (<= min-value 100) 15 0) | |
979 | (values 100 (choose-uniformly 'amber | |
980 | 'amethyst | |
981 | 'coral | |
982 | 'garnet | |
983 | 'jade))) | |
984 | ((if (<= min-value 500) 21 0) | |
985 | (values 500 (choose-uniformly 'aquamarine | |
986 | 'pearl | |
987 | 'topaz))) | |
988 | ((if (<= min-value 1000) 25 0) | |
989 | (values 1000 (choose-uniformly 'carbuncle | |
990 | 'opal))) | |
991 | ((if (<= min-value 5000) 19 0) | |
992 | (values 5000 (choose-uniformly 'emerald | |
993 | 'ruby | |
994 | 'sapphire))) | |
995 | ((if (<= min-value 10000) 7 0) | |
996 | (values 10000 'diamond 'jacinth)) | |
997 | ((if (<= min-value 1000) 1 0) | |
998 | (values (* 1000 (d 100)) | |
999 | 'tristal)) | |
1000 | ((if (and (not recursivep) | |
1001 | (<= min-value 2000)) 2 0) | |
1002 | (multiple-value-bind | |
1003 | (value kind) | |
1004 | (gem-type :min-value (max 1000 | |
1005 | (ceiling min-value 2)) | |
1006 | :recursivep t) | |
1007 | (values (* 2 value) | |
1008 | (intern (format nil "STAR-~A" | |
1009 | (string kind)))))))) | |
1010 | (gems (n) | |
1011 | (tagged-bag | |
1012 | :gems | |
1013 | (loop while (plusp n) | |
1014 | for i = (min n (d 5)) | |
1015 | do (decf n i) | |
1016 | collect | |
1017 | (let ((mods (choose 4 :size 4 :qual 2 :both)) | |
1018 | (mod-list nil)) | |
1019 | (multiple-value-bind | |
1020 | (value kind) | |
1021 | (gem-type) | |
1022 | (when (or (eq mods :size) | |
1023 | (eq mods :both)) | |
1024 | (multiple-value-bind | |
1025 | (mod mult) | |
1026 | (pick (1 (values 'very-small 1/8)) | |
1027 | (2 (values 'small 1/4)) | |
1028 | (2 (values 'fairly-small 1/2)) | |
1029 | (2 (values 'fairly-large 2)) | |
1030 | (2 (values 'large 4)) | |
1031 | (1 (values 'very-small 8))) | |
1032 | (setf mod-list | |
1033 | (append `(:size ,mod) mod-list)) | |
1034 | (setf value (* value mult)))) | |
1035 | (when (or (eq mods :qual) | |
1036 | (eq mods :both)) | |
1037 | (multiple-value-bind | |
1038 | (mod mult) | |
1039 | (pick (1 (values 'very-poor 1/8)) | |
1040 | (2 (values 'poor 1/4)) | |
1041 | (2 (values 'fairly-poor 1/2)) | |
1042 | (2 (values 'fairly-good 2)) | |
1043 | (2 (values 'good 4)) | |
1044 | (1 (values 'very-good 8))) | |
1045 | (setf mod-list | |
1046 | (append `(:size ,mod) mod-list)) | |
1047 | (setf value (* value mult)))) | |
1048 | `(:kind ,kind | |
1049 | :value ,(max 1 (round value)) | |
1050 | ,@mod-list | |
1051 | ,@(and (> i 1) `(:quantity ,i)))))))) | |
1052 | (jewellery (n) | |
1053 | (tagged-bag | |
1054 | :jewellery | |
1055 | (loop while (plusp n) | |
1056 | for i = (min n (d 5)) | |
1057 | do (decf n i) | |
1058 | collect | |
1059 | (multiple-value-bind | |
1060 | (value enc class) | |
1061 | (pick ( 1 (values 100 10 'a)) | |
1062 | ( 2 (values 500 10 'a)) | |
1063 | ( 3 (values 1000 10 'a)) | |
1064 | ( 4 (values 1500 10 'a)) | |
1065 | ( 5 (values 2000 10 'a)) | |
1066 | ( 8 (values 2500 10 'a)) | |
1067 | (10 (values 3000 25 'a)) | |
1068 | (11 (values 4000 25 'b)) | |
1069 | (13 (values 5000 25 'b)) | |
1070 | (11 (values 7500 25 'b)) | |
1071 | ( 9 (values 10000 25 'b)) | |
1072 | ( 7 (values 15000 25 'c)) | |
1073 | ( 5 (values 20000 50 'c)) | |
1074 | ( 4 (values 25000 50 'c)) | |
1075 | ( 3 (values 30000 50 'c)) | |
1076 | ( 2 (values 40000 50 'c)) | |
1077 | ( 1 (values 50000 50 'c))) | |
1078 | (let ((kind (ecase class | |
1079 | ((a) (choose-uniformly 'anklet | |
1080 | 'beads | |
1081 | 'bracelet | |
1082 | 'brooch | |
1083 | 'buckle | |
1084 | 'cameo | |
1085 | 'chain | |
1086 | 'clasp | |
1087 | 'locket | |
1088 | 'pin)) | |
1089 | ((b) (choose-uniformly 'armband | |
1090 | 'belt | |
1091 | 'collar | |
1092 | 'earring | |
1093 | 'four-leaf-clover | |
1094 | 'heart | |
1095 | 'leaf | |
1096 | 'necklace | |
1097 | 'pendant | |
1098 | 'rabbit-foot)) | |
1099 | ((c) (choose-uniformly 'amulet | |
1100 | 'crown | |
1101 | 'diadem | |
1102 | 'medallion | |
1103 | 'orb | |
1104 | 'ring | |
1105 | 'scarab | |
1106 | 'sceptre | |
1107 | 'talisman | |
1108 | 'tiara))))) | |
1109 | `(:kind ,kind | |
1110 | :value ,value | |
1111 | :encumbrance ,enc | |
1112 | ,@(and (> i 1) `(:quantity ,i)))))))) | |
1113 | (magic (&rest forms) | |
1114 | (tagged-bag :magic | |
1115 | (loop with list = nil | |
1116 | for (form n) on forms by #'cddr do | |
1117 | (loop repeat n do | |
1118 | (dolist (item (magic-item form)) | |
1119 | (push item list))) | |
1120 | finally (return list))))) | |
1121 | (ecase type-code | |
1122 | ||
1123 | ;; treasure in lair | |
1124 | ((a) (bag (tagged-bag :coins | |
1125 | (and (percentp 25) `(:cp ,(* 1000 (d 6)))) | |
1126 | (and (percentp 30) `(:sp ,(* 1000 (d 6)))) | |
1127 | (and (percentp 20) `(:ep ,(* 1000 (d 4)))) | |
1128 | (and (percentp 35) `(:gp ,(* 1000 (d 6 2)))) | |
1129 | (and (percentp 25) `(:pp ,(* 1000 (d 2))))) | |
1130 | (and (percentp 50) (gems (d 6 6))) | |
1131 | (and (percentp 50) (jewellery (d 6 6))) | |
1132 | (and (percentp 10) (special (d 2))) | |
1133 | (and (percentp 30) (magic t 3)))) | |
1134 | ((b) (bag (tagged-bag :coins | |
1135 | (and (percentp 50) `(:cp ,(* 1000 (d 8)))) | |
1136 | (and (percentp 25) `(:sp ,(* 1000 (d 6)))) | |
1137 | (and (percentp 25) `(:ep ,(* 1000 (d 4)))) | |
1138 | (and (percentp 35) `(:gp ,(* 1000 (d 3))))) | |
1139 | (and (percentp 25) (gems (d 6))) | |
1140 | (and (percentp 25) (jewellery (d 6))) | |
1141 | (and (percentp 10) | |
1142 | (magic '(or :armour :missile :sword :weapon) 1)))) | |
1143 | ((c) (bag (tagged-bag :coins | |
1144 | (and (percentp 20) `(:cp ,(* 1000 (d 12)))) | |
1145 | (and (percentp 30) `(:sp ,(* 1000 (d 4)))) | |
1146 | (and (percentp 10) `(:ep ,(* 1000 (d 4))))) | |
1147 | (and (percentp 50) (gems (d 6 6))) | |
1148 | (and (percentp 50) (jewellery (d 6 6))) | |
1149 | (and (percentp 5) (special (d 2))) | |
1150 | (and (percentp 10) (magic t 2)))) | |
1151 | ((d) (bag (tagged-bag :coins | |
1152 | (and (percentp 10) `(:cp ,(* 1000 (d 8)))) | |
1153 | (and (percentp 15) `(:sp ,(* 1000 (d 12)))) | |
1154 | (and (percentp 60) `(:gp ,(* 1000 (d 6))))) | |
1155 | (and (percentp 30) (gems (d 8))) | |
1156 | (and (percentp 30) (jewellery (d 8))) | |
1157 | (and (percentp 10) (special (d 2))) | |
1158 | (and (percentp 10) (magic t 1 :potion 1)))) | |
1159 | ((e) (bag (tagged-bag :coins | |
1160 | (and (percentp 5) `(:cp ,(* 1000 (d 10)))) | |
1161 | (and (percentp 30) `(:sp ,(* 1000 (d 12)))) | |
1162 | (and (percentp 25) `(:ep ,(* 1000 (d 4)))) | |
1163 | (and (percentp 25) `(:gp ,(* 1000 (d 8))))) | |
1164 | (and (percentp 10) (gems (d 10))) | |
1165 | (and (percentp 10) (jewellery (d 10))) | |
1166 | (and (percentp 15) (special (d 2))) | |
1167 | (and (percentp 25) (magic t 3 :scroll 1)))) | |
1168 | ((f) (bag (tagged-bag :coins | |
1169 | (and (percentp 30) `(:sp ,(* 1000 (d 10 2)))) | |
1170 | (and (percentp 20) `(:ep ,(* 1000 (d 8)))) | |
1171 | (and (percentp 45) `(:gp ,(* 1000 (d 12)))) | |
1172 | (and (percentp 30) `(:pp ,(* 1000 (d 3))))) | |
1173 | (and (percentp 20) (gems (d 12 2))) | |
1174 | (and (percentp 10) (jewellery (d 12))) | |
1175 | (and (percentp 20) (special (d 3))) | |
1176 | (and (percentp 30) (magic :potion 1 :scroll 1 | |
1177 | '(not :armour :missile | |
1178 | :sword :weapon) 3)))) | |
1179 | ((g) (bag (tagged-bag :coins | |
1180 | (and (percentp 50) `(:gp ,(* 10000 (d 4)))) | |
1181 | (and (percentp 50) `(:pp ,(* 1000 (d 6))))) | |
1182 | (and (percentp 25) (gems (d 6 3))) | |
1183 | (and (percentp 25) (jewellery (d 10))) | |
1184 | (and (percentp 30) (special (d 3))) | |
1185 | (and (percentp 35) (magic t 4 :scroll 1)))) | |
1186 | ((h) (bag (tagged-bag :coins | |
1187 | (and (percentp 25) `(:cp ,(* 1000 (d 8 3)))) | |
1188 | (and (percentp 50) `(:sp ,(* 1000 (d 100)))) | |
1189 | (and (percentp 50) `(:ep ,(* 10000 (d 4)))) | |
1190 | (and (percentp 50) `(:gp ,(* 10000 (d 6)))) | |
1191 | (and (percentp 25) `(:pp ,(* 1000 (d 4 5))))) | |
1192 | (and (percentp 50) (gems (d 100))) | |
1193 | (and (percentp 50) (jewellery (* 10 (d 4)))) | |
1194 | (and (percentp 10) (special (d 2))) | |
1195 | (and (percentp 15) (magic t 4 :potion 1 :scroll 1)))) | |
1196 | ((i) (bag (tagged-bag :coins | |
1197 | (and (percentp 30) `(:pp ,(* 1000 (d 8))))) | |
1198 | (and (percentp 50) (gems (d 6 2))) | |
1199 | (and (percentp 50) (jewellery (d 6 2))) | |
1200 | (and (percentp 5) (special (d 2))) | |
1201 | (and (percentp 15) (magic t 1)))) | |
1202 | ((j) (bag (tagged-bag :coins | |
1203 | (and (percentp 25) `(:cp ,(* 1000 (d 4)))) | |
1204 | (and (percentp 10) `(:sp ,(* 1000 (d 3))))))) | |
1205 | ((k) (bag (tagged-bag :coins | |
1206 | (and (percentp 30) `(:sp ,(* 1000 (d 6)))) | |
1207 | (and (percentp 10) `(:ep ,(* 1000 (d 2))))))) | |
1208 | ((l) (bag (and (percentp 50) (gems (d 4))))) | |
1209 | ((m) (bag (and (percentp 55) (gems (d 4))) | |
1210 | (and (percentp 45) (jewellery (d 6 2))))) | |
1211 | ((n) (bag (and (percentp 10) (special (d 2))) | |
1212 | (and (percentp 40) (magic :potion (d 4 2))))) | |
1213 | ((o) (bag (and (percentp 10) (special (d 3))) | |
1214 | (and (percentp 50) (magic :scroll (d 4))))) | |
1215 | ||
1216 | ;; treasure carried | |
1217 | ((p) (bag (tagged-bag :coins `(:cp ,(d 8 3))))) | |
1218 | ((q) (bag (tagged-bag :coins `(:sp ,(d 6 3))))) | |
1219 | ((r) (bag (tagged-bag :coins `(:ep ,(d 6 2))))) | |
1220 | ((s) (bag (tagged-bag :coins `(:gp ,(d 4 2))) | |
1221 | (and (percentp 5) (gems 1)))) | |
1222 | ((t) (bag (tagged-bag :coins `(:pp ,(d 6 1))) | |
1223 | (and (percentp 5) (gems 1)))) | |
1224 | ((u) (bag (tagged-bag :coins | |
1225 | (and (percentp 10) `(:cp ,(d 100))) | |
1226 | (and (percentp 10) `(:sp ,(d 100))) | |
1227 | (and (percentp 5) `(:gp ,(d 100)))) | |
1228 | (and (percentp 5) (gems (d 2))) | |
1229 | (and (percentp 5) (gems (d 4))) | |
1230 | (and (percentp 2) (special 1)) | |
1231 | (and (percentp 2) (magic t 1)))) | |
1232 | ((v) (bag (tagged-bag :coins | |
1233 | (and (percentp 10) `(:sp ,(d 100))) | |
1234 | (and (percentp 5) `(:ep ,(d 100))) | |
1235 | (and (percentp 5) `(:gp ,(d 100))) | |
1236 | (and (percentp 5) `(:pp ,(d 100)))) | |
1237 | (and (percentp 10) (gems (d 2))) | |
1238 | (and (percentp 10) (gems (d 4))) | |
1239 | (and (percentp 5) (special 1)) | |
1240 | (and (percentp 5) (magic t 1)))) | |
1241 | ||
1242 | ;; unguarded treasures | |
1243 | ((unguarded-1) | |
1244 | (bag (tagged-bag :coins | |
1245 | `(:sp ,(* 100 (d 6))) | |
1246 | (and (percentp 50) `(:gp ,(* 10 (d 6))))) | |
1247 | (and (percentp 5) (gems (d 6))) | |
1248 | (and (percentp 2) (jewellery (d 6))) | |
1249 | (and (percentp 2) (magic t 1)))) | |
1250 | ((unguarded-2 unguarded-3) | |
1251 | (bag (tagged-bag :coins | |
1252 | `(:sp ,(* 100 (d 12))) | |
1253 | (and (percentp 50) `(:gp ,(* 100 (d 6))))) | |
1254 | (and (percentp 10) (gems (d 6))) | |
1255 | (and (percentp 5) (jewellery (d 6))) | |
1256 | (and (percentp 8) (magic t 1)))) | |
1257 | ((unguarded-4 unguarded-5) | |
1258 | (bag (tagged-bag :coins | |
1259 | `(:sp ,(* 1000 (d 6))) | |
1260 | `(:gp ,(* 200 (d 6)))) | |
1261 | (and (percentp 20) (gems (d 8))) | |
1262 | (and (percentp 10) (jewellery (d 8))) | |
1263 | (and (percentp 10) (magic t 1)))) | |
1264 | ((unguarded-6 unguarded-7) | |
1265 | (bag (tagged-bag :coins | |
1266 | `(:sp ,(* 2000 (d 6))) | |
1267 | `(:gp ,(* 500 (d 6)))) | |
1268 | (and (percentp 30) (gems (d 10))) | |
1269 | (and (percentp 15) (jewellery (d 10))) | |
1270 | (and (percentp 15) (magic t 1)))) | |
1271 | ((unguarded-8 unguarded-9) | |
1272 | (bag (tagged-bag :coins | |
1273 | `(:sp ,(* 5000 (d 6))) | |
1274 | `(:gp ,(* 1000 (d 6)))) | |
1275 | (and (percentp 40) (gems (d 12))) | |
1276 | (and (percentp 20) (jewellery (d 12))) | |
1277 | (and (percentp 20) (magic t 1))))))) |