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)))))
8 (reduce #'+ (cond (best (subseq rolls (- k best)))
9 (worst (subseq rolls 0 worst))
12 (defvar *dnd-alist* nil)
14 (defun do-lookup (name default defaultp)
15 (let ((item (assoc name *dnd-alist*)))
16 (cond (item (cdr item))
18 (t (error "Missing required item ~S." name)))))
20 (defun lookup-list (name &optional (default nil defaultp))
21 (do-lookup name default defaultp))
23 (defun lookup (name &optional (default nil defaultp))
24 (car (do-lookup name (list default) defaultp)))
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)
33 ((and (integerp dice) (plusp dice)) (d 8 dice))
34 (t (error "Bad hit dice ~S." hd)))
37 (defun hd-table-lookup (hd table)
39 (let ((aa (if (consp a) (car a) a))
40 (bb (if (consp b) (car b) b)))
45 (loop for ((lo . hi) . rest) in table
46 when (and (hd<= lo hd)
49 finally (return nil))))
51 (let ((xp-table '((( 0 . (0 +)) 5 1)
53 ((( 1 +) . (1 +)) 15 4)
55 ((( 2 +) . (2 +)) 25 10)
57 ((( 3 +) . (3 +)) 50 25)
59 ((( 4 +) . (4 +)) 125 75)
61 ((( 5 +) . (5 +)) 225 175)
63 ((( 6 +) . (6 +)) 350 300)
65 ((( 7 +) . (7 +)) 550 475)
67 ((( 8 +) . (8 +)) 775 625)
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)
92 (destructuring-bind (base bonus) result
93 (+ base (* stars bonus)))
94 (let ((steps (+ hd-base -21 hd-plus)))
97 (* (+ 2000 (* 250 steps)) stars)))))))))
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)
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)))
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
147 (:required (lookup-list tag))
148 (:eval (run tag (car tail)))
149 (:list (run tag (lambda () (list (funcall (car tail))))))
151 finally (return *dnd-alist*))))
153 (defun percentp (pc) (< (random 100) pc))
155 (defun bag (&rest things)
156 (loop for i in things
159 (defun tagged-bag (tag &rest things)
160 (let ((bag (apply #'bag things)))
161 (and bag (cons tag bag))))
163 (defun choose (&rest things)
166 (do ((things things (cddr things)))
168 (let ((k (car things)))
170 (when (and (plusp n) (< (random n) k))
171 (setf it (cadr things)))))))
173 (defun choose-uniformly (&rest things)
174 (let ((n 0) (it nil))
175 (do ((things things (cdr things)))
178 (when (< (random n) 1)
179 (setf it (car things))))))
181 (defmacro pick (&body clauses)
182 `(funcall (choose ,@(loop for (n . clause) in clauses
184 collect `(lambda () ,@clause)))))
186 (defmacro pick-matching ((form &key) &body clauses)
187 (let ((formtemp (gensym "FORM")))
188 `(let ((,formtemp ,form))
189 (pick ,@(loop for (prob assertion . code) in clauses
190 collect `((if (assertion-match-p ,formtemp ',assertion)
195 (defconstant cleric-spells
196 #((cure-light-wounds detect-evil detect-magic light protection-from-evil
197 purify-food-and-water remove-fear resist-cold)
198 (bless find-traps hold-person resist-fire silence-15-ft-radius
199 slow-poison snake-charm speak-with-animal)
200 (continual-light cure-blindness cure-disease growth-of-animals
201 locate-object remove-curse speak-with-the-dead striking)
202 (animate-dead create-water cure-serious-wounds dispel-magic
203 neutralize-poison protection-from-evil-10-ft-radius speak-with-plants
205 (commune create-food cure-critical-wounds dispel-evil insect-plague quest
206 raise-dead truesight)
207 (aerial-servant animate-objects barrier create-normal-animals cureall
208 find-the-path speak-with-monsters word-of-recall)
209 (earthquake holy-word raise-dead-fully restore survival travel wish
212 (defconstant druid-only-spells
213 #((detect-danger faerie-fire locate predict-weather)
214 (heat-metal obscure produce-fire warp-wood)
215 (call-lightning hold-animal protection-from-poison water-breathing)
216 (control-temperature-10-ft-radius plant-door protection-from-lightning
218 (anti-plant-shell control-winds dissolve pass-plant)
219 (anti-animal-shell summon-weather transport-through-plants turn-wood)
220 (creeping-doom metal-to-wood summon-elemental weather-control)))
222 (defconstant druid-spells
223 (make-array 7 :initial-contents (loop for cs across cleric-spells
224 for ds across druid-only-spells
225 collect (append cs ds))))
227 (defconstant magic-user-spells
228 #((analyse charm-person detect-magic floating-disc hold-portal light
229 magic-missile protection-from-evil read-languages read-magic shield
231 (continual-light detect-evil detect-invisible entangle esp invisibility
232 knock levitate locate-object mirror-image phantasmal-force web
234 (clairvoyance create-air dispel-magic fire-ball fly haste hold-person
235 infravision invisibility-10-ft-radius lightning-bolt
236 protection-from-evil-10-ft-radius protection-from-normal-missiles
238 (charm-monster clothform confusion dimension-door growth-of-plants
239 hallucinatory-terrain ice-storm/wall massmorph polymorph-others
240 polymorph-self remove-curse wall-of-fire wizard-eye)
241 (animate-dead cloudkill conjure-elemental contact-outer-plane dissolve
242 feeblemind hold-monster magic-jar pass-wall telekinesis teleport
243 wall-of-stone woodform)
244 (anti-magic-shell death-spell disintegrate geas invisible-stalker
245 lower-water move-earth projected-image reincarnation stone-to-flesh
246 stoneform wall-of-iron weather-control)
247 (charm-plant create-normal-monsters delayed-blast-fire-ball ironform lore
248 magic-door mass-invisibility power-word-stun reverse-gravity statue
249 summon-object sword teleport-any-object)
250 (clone create-magical-monsters dance explosive-cloud force-field
251 mass-charm mind-barrier permanence polymorph-any-object power-word-blind
252 steelform symbol travel)
253 (contingency create-any-monster gate heal immunity maze meteor-swarm
254 power-word-kill prismatic-wall shapechange survival timestop wish)))
256 (defun spell-caster-type (&optional (form :any))
257 (pick-matching (form)
258 (5 (:user (:cleric :druid :paladin)) :cleric)
259 (1 (:user :druid) :druid)
260 (14 (:user (:magic-user :elf :thief)) :magic-user)))
262 (defun random-spell (&optional (caster (spell-caster-type))
264 ((:magic-user) (choose 28 1
273 ((:cleric :druid) (choose 34 1
280 (let ((list (aref (ecase caster
281 ((:magic-user) magic-user-spells)
282 ((:cleric) cleric-spells)
283 ((:druid) druid-only-spells))
285 (values (elt list (random (length list)))
289 (let ((magic (list :magic)))
290 (defun assertion-match-p (form assertions)
291 (cond ((eq form :any) t)
292 ((eq form :none) nil)
293 ((atom form) (if (atom assertions)
294 (eql form assertions)
295 (member form assertions)))
297 ((and) (every (lambda (f)
298 (assertion-match-p f assertions))
300 ((or) (some (lambda (f)
301 (assertion-match-p f assertions))
303 ((not) (not (assertion-match-p (cadr form) assertions)))
304 (t (let ((sub (getf assertions (car form) magic)))
307 (assertion-match-p (cadr form) sub)))))))))
309 (defun choose-distinct-items (n seq)
310 (let* ((copy (subseq (coerce seq 'vector) 0))
313 (dotimes (i n (sort list #'string<))
314 (let ((j (random len)))
315 (push (aref copy j) list)
317 (setf (aref copy j) (aref copy len))))))
319 (defun magic-item (form)
320 (labels ((cursedp (&optional (prob 10))
321 (cond ((assertion-match-p form '(:cursed :unspecified))
322 (zerop (random prob)))
323 ((assertion-match-p form '(:cursed nil))
326 (potion (&key recursivep)
327 (pick-matching (form)
328 (2 (:cursed nil) `(:potion agility))
329 (1 (:cursed nil) `(:potion animal-control))
330 (3 (:cursed nil) `(:potion antidote))
331 (2 (:cursed nil) `(:potion blending))
332 (2 (:cursed nil) `(:potion bug-repellent))
333 (2 (:cursed nil) `(:potion clairaudience))
334 (2 (:cursed nil) `(:potion clairvoyance))
335 (2 (:cursed nil) `(:potion climbing))
336 (2 (:cursed nil) `(:potion defence :bonus ,(choose 3 1
341 ((if recursivep 0 4) (:cursed t)
344 :fakes ,@(cdr (potion :recursivep t))))
345 (2 (:cursed nil) `(:potion diminution))
346 (1 (:cursed nil) `(:potion ,(choose 35 'white-dragon-control
347 15 'crystal-dragon-control
348 35 'black-dragon-control
349 15 'onyx-dragon-control
350 28 'green-dragon-control
351 12 'jade-dragon-control
352 21 'blue-dragon-control
353 9 'sapphire-dragon-control
354 14 'red-dragon-control
355 6 'ruby-dragon-control
356 7 'gold-dragon-control
357 3 'amber-dragon-control)))
358 (2 (:cursed nil) `(:potion dreamspeech))
359 (1 (:cursed nil) `(:potion elasicity))
360 (2 (:cursed nil) `(:potion ,(choose-uniformly 'air-form
364 (2 (:cursed nil) `(:potion esp))
365 (1 (:cursed nil) `(:potion ethereality))
366 (3 (:cursed nil) `(:potion fire-resistance))
367 (3 (:cursed nil) `(:potion flying))
368 (2 (:cursed nil) `(:potion fortitude))
369 (1 (:cursed nil) `(:potion freedom))
370 (3 (:cursed nil) `(:potion gaseous-form))
371 (1 (:cursed nil) `(:potion ,(choose 5 'hill-giant-control
372 5 'stone-giant-control
373 4 'frost-giant-control
374 2 'fire-giant-control
375 1 'mountain-giant-control
377 1 'cloud-giant-control
378 1 'storm-giant-control)))
379 (3 (:cursed nil) `(:potion giant-strength))
380 (2 (:cursed nil) `(:potion growth))
381 (6 (:cursed nil) `(:potion healing))
382 (3 (:cursed nil) `(:potion heroism))
383 (1 (:cursed nil) `(:potion human-control))
384 (3 (:cursed nil) `(:potion invisibility))
385 (2 (:cursed nil) `(:potion invulnerability))
386 (2 (:cursed nil) `(:potion levitation))
387 (2 (:cursed nil) `(:potion longevity))
388 (1 (:cursed nil) `(:potion luck))
389 (1 (:cursed nil) `(:potion merging))
390 (2 (:cursed nil) `(:potion plant-control))
391 (3 (:cursed t) `(:potion poison))
392 (3 (:cursed nil) `(:potion polymorph-self))
393 (2 (:cursed nil) `(:potion sight))
394 (2 (:cursed nil) `(:potion speech))
395 (4 (:cursed nil) `(:potion speed))
396 (2 (:cursed nil) `(:potion strength))
397 (3 (:cursed nil) `(:potion super-healing))
398 (3 (:cursed nil) `(:potion swimming))
399 (1 (:cursed nil) `(:potion treasure-finding))
400 (1 (:cursed nil) `(:potion undead-control))
401 (2 (:cursed nil) `(:potion water-breathing))))
403 (pick-matching (form)
404 (3 (:cursed nil) `(:scroll communication))
405 (2 (:cursed nil) `(:scroll creation))
406 (8 (:cursed t) `(:scroll curse))
407 (1 (:user (:cleric :druid :magic-user :elf :thief :paladin)
411 (random-spell (spell-caster-type form))
412 (declare (ignore level))
413 `(:scroll delay :caster ,caster :spells (,spell))))
416 :items ,(choose-distinct-items 6
429 (2 (:cursed nil) `(:scroll illumination))
430 (2 (:cursed nil :user (:magic-user :cleric :druid :elf))
432 (4 (:cursed nil) `(:map normal-treasure))
433 (3 (:cursed nil) `(:map magical-treasure))
434 (2 (:cursed nil) `(:map combined-treasure))
435 (1 (:cursed nil) `(:map special-treasure))
436 (3 (:cursed nil) `(:scroll mapping))
437 (2 (:cursed nil) `(:scroll portals))
438 (6 (:cursed nil) `(:scroll protection-from-elementals))
439 (8 (:cursed nil) `(:scroll protection-from-lycanthropes))
440 (4 (:cursed nil) `(:scroll protection-from-magic))
441 (7 (:cursed nil) `(:scroll protection-from-undead))
442 (2 (:cursed nil) `(:scroll questioning))
444 :user (:cleric :druid :magic-user :elf :thief :paladin))
447 (random-spell (spell-caster-type form))
452 (2 (:cursed nil) `(:scroll seeing))
453 (2 (:cursed nil) `(:scroll shelter))
455 `(:scroll spell-catching :max-level ,(choose 4 1
460 :user (:cleric :druid :magic-user :elf :thief :paladin))
461 (let ((caster (spell-caster-type form))
462 (spells (choose 50 1 33 2 17 3)))
465 :spells ,(loop repeat spells
466 collect (random-spell caster)))))
467 (2 (:cursed nil) `(:scroll trapping))
468 (2 (:cursed nil) `(:scroll truth))))
469 (wand-charges () (d 10 3))
470 (staff-charges () (d 20 2))
472 (pick-matching (form)
473 (5 (:user (:magic-user :elf))
474 `(:wand cold :charges ,(wand-charges)))
475 (5 (:user (:magic-user :elf))
476 `(:wand enemy-detection :charges ,(wand-charges)))
477 (4 (:user (:magic-user :elf))
478 `(:wand fear :charges ,(wand-charges)))
479 (5 (:user (:magic-user :elf))
480 `(:wand fireballs :charges ,(wand-charges)))
481 (4 (:user (:magic-user :elf))
482 `(:wand illusion :charges ,(wand-charges)))
483 (5 (:user (:magic-user :elf))
484 `(:wand lightning-bolts :charges ,(wand-charges)))
485 (5 (:user (:magic-user :elf))
486 `(:wand magic-detection :charges ,(wand-charges)))
487 (5 (:user (:magic-user :elf))
488 `(:wand metal-detection :charges ,(wand-charges)))
489 (4 (:user (:magic-user :elf))
490 `(:wand negation :charges ,(wand-charges)))
491 (5 (:user (:magic-user :elf))
492 `(:wand paralysation :charges ,(wand-charges)))
493 (5 (:user (:magic-user :elf))
494 `(:wand polymorphing :charges ,(wand-charges)))
495 (4 (:user (:magic-user :elf))
496 `(:wand secret-door-detection :charges ,(wand-charges)))
497 (4 (:user (:magic-user :elf))
498 `(:wand trap-detection :charges ,(wand-charges)))
499 (1 (:user (:magic-user :elf :cleric :druid :palatin))
500 `(:staff commanding :charges nil))
502 `(:staff dispelling :charges ,(staff-charges)))
504 `(:staff druids :charges ,(staff-charges)))
505 (3 (:user (:magic-user :elf))
506 `(:staff ,(choose 19 'air
513 :charges ,(staff-charges)))
514 (2 (:user (:cleric :druid :paladin))
515 `(:staff harming :charges ,(staff-charges)))
516 (7 (:user (:cleric :druid :paladin))
517 `(:staff healing :charges ,(staff-charges)))
518 (1 (:user (:cleric :druid :magic-user :elf :paladin))
519 `(:staff power :charges ,(staff-charges)))
520 (3 (:user (:cleric :druid :paladin))
521 `(:staff snake :charges ,(staff-charges)))
522 (3 (:user (:cleric :druid :magic-user :elf :paladin))
523 `(:staff striking :charges ,(staff-charges)))
524 (2 (:user (:cleric :druid :paladin))
525 `(:staff withering :charges ,(staff-charges)))
526 (1 (:user (:magic-user :elf))
527 `(:staff wizardry :charges ,(staff-charges)))
528 (2 nil `(:rod cancellation))
529 (1 nil `(:rod dominion))
530 (1 (:user (:cleric :druid :paladin)) `(:rod health))
531 (2 (:user (:dwarf :halfling :elf :fighter
532 :paladin :thief :mystic))
534 (1 nil `(:rod parrying))
535 (1 nil `(:rod victory))
536 (3 (:user (:dwarf :halfling :elf :fighter
537 :paladin :thief :mystic))
540 `(:rod wyrm :colour ,(choose 5 'gold
543 (ring (&optional (recursivep nil))
544 (pick-matching (form)
545 (2 (:cursed nil) `(:ring animal-control))
549 `(:ring delusion :fakes ,@(cdr (ring t))))
550 (1 (:cursed nil) `(:ring djinni-summoning))
551 (4 (:cursed nil) `(:ring ear))
552 (4 (:cursed nil) `(:ring ,(choose 19 'air-adaptation
556 6 'air-and-water-adaptation
557 6 'earth-and-fire-adaptation
558 2 'elemental-adaptation)))
559 (6 (:cursed nil) `(:ring fire-resistance))
560 (3 (:cursed nil :user (:cleric :druid :paladin))
562 (1 (:cursed nil) `(:ring human-control))
563 (5 (:cursed nil) `(:ring invisibility))
564 (3 (:cursed nil) `(:ring life-protection :charges ,(d 6)))
566 :user (:cleric :druid :magic-user :elf :paladin))
568 (2 (:cursed nil) `(:ring plant-control))
569 (1 (:cursed nil) `(:ring protection :bonus 1 :radius 5))
570 (10 (:cursed nil) `(:ring protection :bonus ,(choose 4 1
574 (4 (:cursed nil) `(:ring quickness))
575 (1 (:cursed nil) `(:ring regeneration))
576 (3 (:cursed nil) `(:ring remedies))
577 (2 (:cursed nil) `(:ring safety :charges ,(d 4)))
578 (3 (:cursed nil) `(:ring seeing))
579 (3 (:cursed t) `(:ring spell-eating))
581 (let* ((caster (spell-caster-type))
582 (spells (loop repeat (d 6)
583 collect (random-spell caster))))
584 `(:ring spell-storing
586 :spells ,(remove-duplicates (sort spells
588 (2 (:cursed nil) `(:ring spell-turning))
589 (4 (:cursed nil) `(:ring survival :charges ,(+ 100 (d 100))))
590 (2 (:cursed nil) `(:ring telekinesis))
591 (4 (:cursed nil) `(:ring truth))
592 (3 (:cursed t) `(:ring truthfulness))
593 (2 (:cursed t) `(:ring truthlessness))
594 (5 (:cursed nil) `(:ring water-walking))
595 (5 (:cursed t) `(:ring weakness))
596 (2 (:cursed nil) `(:ring wishes :charges ,(choose 4 1
600 (2 (:cursed nil) `(:ring x-ray-vision))))
602 (pick-matching (form)
604 `(:amulet protection-from-crystal-balls-and-esp))
605 (2 (:cursed t) `(:bag devouring))
606 (5 (:cursed nil) `(:bag holding))
607 (3 (:cursed nil) `(:boat undersea))
608 (2 (:cursed nil) `(:boots levitation))
609 (3 (:cursed nil) `(:boots speed))
610 (2 (:cursed nil) `(:boots travelling-and-leaping))
611 (1 (:cursed nil) `(:bowl commanding-water-elementals))
612 (1 (:cursed nil) `(:brazier commanding-fire-elementals))
613 (2 (:cursed nil) `(:broom flying))
614 (1 (:cursed nil) `(:censer controlling-air-elementals))
615 (3 (:cursed nil) `(:chime time))
616 (2 (:cursed nil :user (:magic-user :elf))
617 `(:crystal-ball normal))
618 (1 (:cursed nil :user (:magic-user :elf))
619 `(:crystal-ball clairaudience))
620 (1 (:cursed nil :user (:magic-user :elf))
621 `(:crystal-ball esp))
622 (2 (:cursed nil) `(:cloak displacer))
623 (1 (:cursed nil) `(:drums panic))
624 (1 (:cursed nil) `(:bottle efreeti))
625 (3 (:cursed nil) `(:egg ,(choose-uniformly 'rock-baboon
637 (2 (:cursed nil) `(:boots elven))
638 (2 (:cursed nil) `(:cloak elven))
639 (1 (:cursed nil) `(:carpet flying))
640 (2 (:cursed nil) `(:gauntlets ogre-power))
641 (2 (:cursed nil) `(:girdle giant-strength))
643 `(:helm ,(choose-uniformly 'lawful-alignment
645 'chaotic-alignment)))
646 (2 (:cursed nil) `(:helm reading))
647 (1 (:cursed nil) `(:helm telepathy))
648 (1 (:cursed nil) `(:helm teleportation))
649 (1 (:cursed nil) `(:horn blasting))
650 (2 (:cursed t) `(:lamp hurricane))
651 (3 (:cursed nil) `(:lamp long-burning))
652 (2 (:cursed nil) `(:medallion esp-30-ft-range))
653 (1 (:cursed nil) `(:medallion esp-90-ft-range))
654 (1 (:cursed nil) `(:mirror life-trapping))
655 ; fixme include contents
656 (3 (:cursed nil) `(:muzzle training))
657 (2 (:cursed nil) `(:nail finger))
658 (3 (:cursed nil) `(:nail pointing))
659 (5 nil `(:ointment ,(pick-matching (form)
660 (1 (:cursed nil) 'blessing)
661 (1 (:cursed nil) 'healing)
662 (1 (:cursed t) 'poison)
663 (1 (:cursed t) 'scarring)
664 (1 (:cursed nil) 'soothing)
665 (1 (:cursed t) 'tanning))))
666 (3 (:cursed nil) `(:pouch security))
667 (3 (:cursed nil :user (:cleric :druid :magic-user :elf))
669 (4 (:cursed nil) `(:rope climbing))
670 (2 (:cursed nil) `(:scarab protection :charges ,(d 6 2)))
671 (3 (:cursed nil :user (:cleric :druid :magic-user :elf))
672 `(:slate identification))
673 (1 (:cursed nil) `(:stone controlling-earth-elementals))
675 `(:talisman ,(choose-uniformly 'air-travel
680 (3 (:cursed nil) `(:wheel floating))
681 (1 (:cursed nil) `(:wheel fortune))
682 (2 (:cursed nil) `(:wheel square))))
683 (weapon-bonus (class)
684 (loop for bonus from 1
685 for roll = (random 100) then (- roll item)
686 for item in (ecase class
687 ((a) '(40 27 17 10 6))
688 ((b) '(50 24 14 8 4))
689 ((c) '(60 21 11 6 2))
690 ((d) '(70 18 8 3 1)))
691 when (< roll item) return bonus))
693 (pick-matching (form)
694 (68 (:user (:cleric :fighter :paladin :druid :thief)) 'human)
695 (13 (:user :dwarf) 'dwarf)
696 (10 (:user :elf) 'elf)
697 (7 (:user :halfling) 'halfling)
698 (2 (:user nil) 'giant)))
699 (armour-piece (class)
700 (let* ((bonus (weapon-bonus class))
701 (power (and (percentp (* 5 (1+ bonus)))
702 (pick (7 `(absorption))
713 (7 `(remove-curse :charges ,(d 3))))))
714 (cursedp (if (and power (eq (car power) 'remove-curse))
718 ,@(and power (cons :power power))
720 ,@(and cursedp `(:cursed t)))))
722 (pick-matching (form)
723 (10 (:user (:cleric :fighter :paladin :druid :thief
724 :dwarf :elf :halfling))
725 `((:armour leather ,@(armour-piece 'd))))
726 ( 7 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
727 `((:armour scale-mail ,@(armour-piece 'd))))
728 (13 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
729 `((:armour chain-mail ,@(armour-piece 'c))))
730 ( 9 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
731 `((:armour banded-mail ,@(armour-piece 'd))))
732 (11 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
733 `((:armour plate-mail ,@(armour-piece 'b))))
734 ( 5 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
735 `((:armour suit ,@(armour-piece 'b))))
736 (20 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
737 `((:shield ,@(armour-piece 'a))))
738 ( 2 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
739 `((:armour scale-mail ,@(armour-piece 'd))
740 (:shield ,@(armour-piece 'a))))
741 ( 8 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
742 `((:armour chain-mail ,@(armour-piece 'c))
743 (:shield ,@(armour-piece 'a))))
744 ( 5 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
745 `((:armour banded-mail ,@(armour-piece 'd))
746 (:shield ,@(armour-piece 'a))))
747 (10 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
748 `((:armour plate-mail ,@(armour-piece 'b))
749 (:shield ,@(armour-piece 'a))))))
754 9 'enchanted-monsters
758 6 'regenerating-monsters
759 9 'reptiles-and-dinosaurs
760 3 'spell-immune-monsters
763 6 'water-breathing-monsters
764 6 'weapon-using-monsters))
765 (weapon-talent (&key missilep)
766 (pick (5 `(breathing))
769 ((if missilep 0 7) `(defending))
771 (2 `(draining :charges ,(+ 4 (d 4))))
786 (1 `(wishing :charges ,(d 3)))))
787 (weapon-modifier (bonus &rest keys &key &allow-other-keys)
788 (and (percentp (aref #(40 30 20 15 10) (1- bonus)))
789 (pick (33 `(:extra (,(+ bonus 1) :against ,(opponent))))
790 (24 `(:extra (,(+ bonus 2) :against ,(opponent))))
791 (16 `(:extra (,(+ bonus 3) :against ,(opponent))))
792 (9 `(:extra (,(+ bonus 4) :against ,(opponent))))
793 (3 `(:extra (,(+ bonus 5) :against ,(opponent))))
794 (15 `(:talent ,@(apply #'weapon-talent keys))))))
795 (sword-modifier (bonus &rest keys &key &allow-other-keys)
796 (and (percentp (aref #(40 30 25 20 15) (1- bonus)))
797 (pick (29 `(:extra (,(+ bonus 1) :against ,(opponent))))
798 (21 `(:extra (,(+ bonus 2) :against ,(opponent))))
799 (14 `(:extra (,(+ bonus 3) :against ,(opponent))))
800 (8 `(:extra (,(+ bonus 4) :against ,(opponent))))
801 (3 `(:extra (,(+ bonus 5) :against ,(opponent))))
802 (25 `(:talent ,@(apply #'weapon-talent keys))))))
806 (pick-matching (form)
807 (37 (:user (:thief :fighter :paladin :mystic
808 :dwarf :elf :halfling))
810 (22 (:user (:thief :fighter :paladin :mystic
811 :dwarf :elf :halfling))
812 (values :quarrel 'a))
813 (11 (:user (:cleric :druid :thief :fighter :paladin
814 :mystic :dwarf :elf :halfling))
815 (values :sling-stone 'a))
816 (2 (:user (:thief :fighter :paladin :mystic
817 :dwarf :elf :halfling))
818 (values :blowgun 'd))
819 (8 (:user (:thief :fighter :paladin :mystic
820 :dwarf :elf :halfling))
821 (values :long-bow 'd))
822 (5 (:user (:thief :fighter :paladin :mystic
823 :dwarf :elf :halfling))
824 (values :short-bow 'd))
825 (2 (:user (:thief :fighter :paladin :mystic
826 :dwarf :elf :halfling))
827 (values :heavy-crossbow 'd))
828 (5 (:user (:thief :fighter :paladin :mystic
829 :dwarf :elf :halfling))
830 (values :light-crossbow 'd))
831 (8 (:user (:cleric :druid :thief :fighter :paladin
832 :mystic :dwarf :elf :halfling))
835 ((a) (let* ((bonus (weapon-bonus 'a))
836 (cursedp (zerop (random 10)))
837 (talent (and (percentp (* 5 (- 7 bonus)))
853 :opponent ,(opponent)))
865 `(,item :bonus ,bonus
866 ,@(and talent `(:talent ,talent))
868 ,@(and cursedp `(:cursed t)))))
869 ((d) (let* ((bonus (weapon-bonus 'd))
870 (cursedp (cursedp 10))
871 (modifier (weapon-modifier bonus :missilep t))
872 (range (ecase (+ bonus (d 4))
876 `(,item :bonus ,bonus ,@modifier
877 ,@(and range `(:range ,range))
878 ,@(and cursedp `(:cursed t))))))))
879 (weapon-intelligence ()
881 (int langs prim read-magic-p extra)
882 (pick (79 (values nil 0 0 nil 0))
883 (6 (values 7 0 1 nil 0))
884 (5 (values 8 0 2 nil 0))
885 (4 (values 9 0 3 nil 0))
886 (3 (values 10 (d 3) 3 nil 0))
887 (2 (values 11 (d 6) 3 t 0))
888 (1 (values 12 (d 4 2) 3 t 1)))
894 (macrolet ((power-check (&rest forms)
895 `(pick ,@(loop for (tag n . form) in forms
902 (push ',tag checklist)
907 collect `(,n ,@form)))))
908 (labels ((primary-power ()
914 (detect-shifting-walls-and-rooms 15)
915 (detect-sloping-passages 15)
916 (find-secret-doors 10)
920 (extraordinary-power))
924 (extraordinary-power ()
930 (setf damage (if damage
935 (setf healing (+ (or healing 0) 6)))
943 (extraordinary-power)
944 (extraordinary-power))
946 (extraordinary-power)
947 (extraordinary-power)
948 (extraordinary-power)))))
949 (dotimes (i prim) (primary-power))
950 (dotimes (i extra) (extraordinary-power))))
952 (push `(extra-damage ,damage) powers))
954 (push `(healing ,healing) powers))
958 ,@(and read-magic-p `(:read-magic t))
963 (pick-matching (form)
964 (65 nil (values :normal-sword 'c))
965 (19 nil (values :short-sword 'c))
966 (8 (:user (:fighter :paladin :dwarf :mystic :elf))
967 (values :two-handed-sword 'd))
968 (8 (:user (:fighter :paladin :dwarf
969 :mystic :elf :halfling))
970 (values :bastard-sword 'd)))
971 (let* ((bonus (weapon-bonus class))
972 (cursedp (zerop (random 10)))
973 (modifier (sword-modifier bonus))
974 (intel (weapon-intelligence)))
975 `(,type :bonus ,bonus
978 ,@(and cursedp `(:cursed t))))))
981 (type returnsp intelpc class)
982 (pick-matching (form)
983 (7 (:user (:fighter :paladin :mystic :dwarf :elf))
984 (values :battle-axe nil 30 'd))
985 (8 (:user (:fighter :paladin :mystic :dwarf :thief
987 (values :hand-axe (choose 3 nil 1 t) nil 'b))
988 (3 (:user (:fighter :paladin :mystic :dwarf :cleric
990 (values :blackjack nil nil 'c))
991 (3 (:user (:fighter :paladin :mystic :dwarf :cleric
992 :thief :elf :halfling))
993 (values :bola (choose 2 nil 1 t) nil 'b))
994 (5 (:user (:fighter :paladin :mystic :dwarf
995 :thief :cleric :druid :elf :halfling))
996 (values :club nil nil 'c))
997 (14 (:user (:fighter :paladin :mystic :dwarf :magic-user
998 :thief :elf :halfling))
999 (values :dagger (choose 11 nil 3 t) 50 'b))
1000 (4 (:user (:fighter :paladin :mystic :dwarf :cleric
1001 :elf :halfling :thief))
1002 (values :one-handed-flail nil nil 'c))
1003 (2 (:user (:fighter :paladin :mystic :dwarf :cleric :elf))
1004 (values :two-handed-flail nil nil 'd))
1005 (3 (:user (:fighter :paladin :mystic :dwarf :elf))
1006 (values :halberd nil 20 'd))
1007 (8 (:user (:fighter :paladin :mystic :dwarf :cleric
1008 :druid :elf :halfling :thief))
1009 (values :war-hammer nil 30 'c))
1010 (4 (:user (:fighter :paladin :mystic :dwarf :thief
1012 (values :javelin (choose 3 nil 1 t) nil 'b))
1013 (4 (:user (:fighter :paladin :mystic :dwarf :elf))
1014 (values :lance nil nil 'd))
1015 (7 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
1016 :elf :halfling :druid))
1017 (values :mace nil 35 'c))
1018 (5 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
1020 (values :morning-star nil nil 'c))
1021 (3 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
1022 :druid :elf :halfling))
1023 (values :net (choose 2 nil 1 t) nil 'b))
1024 (3 (:user (:fighter :paladin :mystic :dwarf :elf))
1025 (values :pike nil 20 'd))
1026 (2 (:user (:fighter :paladin :mystic :dwarf :elf))
1027 (values :pole-axe nil 20 'd))
1028 (12 (:user (:fighter :paladin :mystic :dwarf :thief
1030 (values :spear (choose 3 nil 1 t) nil 'b))
1031 (4 (:user (:fighter :paladin :mystic :dwarf :thief :cleric
1032 :druid :elf :halfling :magic-user))
1033 (values :staff nil 20 'd))
1034 (3 (:user (:fighter :paladin :mystic :dwarf :thief :cleric
1035 :druid :elf :halfling))
1036 (values :whip nil nil 'c)))
1037 (let* ((bonus (weapon-bonus class))
1038 (cursedp (cursedp 10))
1039 (modifier (sword-modifier bonus))
1042 (weapon-intelligence))))
1044 ,@(and returnsp `(:returning t))
1048 ,@(and cursedp `(:cursed t)))))))
1049 (pick-matching (form)
1050 (25 (:type :potion) (list (potion)))
1051 (12 (:type :scroll) (list (scroll)))
1052 (9 (:type :wandlike :cursed nil) (list (wandlike)))
1053 (6 (:type :ring) (list (ring)))
1054 (10 (:type :misc) (list (misc-item)))
1056 :user (:cleric :druid :fighter :paladin
1057 :thief :dwarf :elf :halfling))
1059 (11 (:type :missile) (list (missile)))
1061 :user (:fighter :paladin :mystic :thief :dwarf :elf :halfling))
1063 (8 (:type :weapon) (list (weapon))))))
1065 (defun treasure-type (type-code)
1066 (labels ((common-fur-type ()
1067 (choose-uniformly 'beaver
1072 (choose-uniformly 'ermine
1080 (pick (10 `(:kind book
1081 :value ,(* 10 (d 100))
1082 :encumbrance ,(d 100)))
1084 :animal ,(common-fur-type)
1086 :encumbrance ,(* 10 (d 6))))
1088 :animal ,(common-fur-type)
1089 :value ,(* 100 (d 6))
1090 :encumbrance ,(* 10 (+ 4 (d 8)))))
1092 :animal ,(common-fur-type)
1093 :value ,(* 100 (d 4 3))
1094 :encumbrance ,(* 10 (+ 8 (d 6 2)))))
1096 :animal ,(rare-fur-type)
1098 :encumbrance ,(* 10 (d 6))))
1100 :animal ,(rare-fur-type)
1101 :value ,(* 100 (d 6 4))
1102 :encumbrance ,(* 10 (+ 4 (d 8)))))
1104 :animal ,(rare-fur-type)
1105 :value ,(* 1000 (d 4))
1106 :encumbrance ,(* 10 (+ 8 (d 6 2)))))
1110 :quantity ,(d 4 2)))
1112 :value ,(* 10 (+ 5 (d 10)))
1114 :quantity ,(d 3 2)))
1115 (5 (let ((w (d 6)) (h (d 2)))
1116 `(:kind ,(choose-uniformly 'rug
1118 :value ,(* w h (d 10 2))
1119 :encumbrance ,(* 100 w h (d 6))
1121 (10 (let ((w (d 8)) (h (d 2)))
1123 :value ,(* w h (d 8))
1124 :encumbrance ,(* 10 w h (d 6))
1126 (10 `(:kind animal-skin
1128 :encumbrance ,(* 10 (d 4 5))))
1129 (10 `(:kind monster-skin
1130 :value ,(* 100 (d 10))
1131 :encumbrance ,(* 50 (d 100))))
1132 (5 (let ((enc (d 100)))
1134 :value ,(* enc (d 4 4))
1135 :encumbrance ,enc)))
1136 (5 `(:kind statuette
1137 :value ,(* 100 (d 10))
1138 :encumbrance ,(d 100)))
1141 :encumbrance ,(* 10 (+ 3 (d 6)))
1142 :bottles ,(d 12)))))))
1143 (gem-type (&key (min-value 0) recursivep)
1144 (pick ((if (<= min-value 10) 3 0)
1145 (values 10 (choose-uniformly 'agate
1148 ((if (<= min-value 50) 7 0)
1149 (values 50 (choose-uniformly 'crystal
1152 ((if (<= min-value 100) 15 0)
1153 (values 100 (choose-uniformly 'amber
1158 ((if (<= min-value 500) 21 0)
1159 (values 500 (choose-uniformly 'aquamarine
1162 ((if (<= min-value 1000) 25 0)
1163 (values 1000 (choose-uniformly 'carbuncle
1165 ((if (<= min-value 5000) 19 0)
1166 (values 5000 (choose-uniformly 'emerald
1169 ((if (<= min-value 10000) 7 0)
1170 (values 10000 'diamond 'jacinth))
1171 ((if (<= min-value 1000) 1 0)
1172 (values (* 1000 (d 100))
1174 ((if (and (not recursivep)
1175 (<= min-value 2000)) 2 0)
1176 (multiple-value-bind
1178 (gem-type :min-value (max 1000
1179 (ceiling min-value 2))
1182 (intern (format nil "STAR-~A"
1183 (string kind))))))))
1187 (loop while (plusp n)
1188 for i = (min n (d 5))
1191 (let ((mods (choose 4 :size 4 :qual 2 :both))
1193 (multiple-value-bind
1196 (when (or (eq mods :size)
1198 (multiple-value-bind
1200 (pick (1 (values 'very-small 1/8))
1201 (2 (values 'small 1/4))
1202 (2 (values 'fairly-small 1/2))
1203 (2 (values 'fairly-large 2))
1204 (2 (values 'large 4))
1205 (1 (values 'very-small 8)))
1207 (append `(:size ,mod) mod-list))
1208 (setf value (* value mult))))
1209 (when (or (eq mods :qual)
1211 (multiple-value-bind
1213 (pick (1 (values 'very-poor 1/8))
1214 (2 (values 'poor 1/4))
1215 (2 (values 'fairly-poor 1/2))
1216 (2 (values 'fairly-good 2))
1217 (2 (values 'good 4))
1218 (1 (values 'very-good 8)))
1220 (append `(:quality ,mod) mod-list))
1221 (setf value (* value mult))))
1223 :value ,(max 1 (round value))
1225 ,@(and (> i 1) `(:quantity ,i))))))))
1229 (loop while (plusp n)
1230 for i = (min n (d 5))
1233 (multiple-value-bind
1235 (pick ( 1 (values 100 10 'a))
1236 ( 2 (values 500 10 'a))
1237 ( 3 (values 1000 10 'a))
1238 ( 4 (values 1500 10 'a))
1239 ( 5 (values 2000 10 'a))
1240 ( 8 (values 2500 10 'a))
1241 (10 (values 3000 25 'a))
1242 (11 (values 4000 25 'b))
1243 (13 (values 5000 25 'b))
1244 (11 (values 7500 25 'b))
1245 ( 9 (values 10000 25 'b))
1246 ( 7 (values 15000 25 'c))
1247 ( 5 (values 20000 50 'c))
1248 ( 4 (values 25000 50 'c))
1249 ( 3 (values 30000 50 'c))
1250 ( 2 (values 40000 50 'c))
1251 ( 1 (values 50000 50 'c)))
1252 (let ((kind (ecase class
1253 ((a) (choose-uniformly 'anklet
1263 ((b) (choose-uniformly 'armband
1273 ((c) (choose-uniformly 'amulet
1286 ,@(and (> i 1) `(:quantity ,i))))))))
1287 (magic (&rest forms)
1289 (loop with list = nil
1290 for (form n) on forms by #'cddr do
1292 (dolist (item (magic-item (list :type form)))
1294 finally (return list)))))
1298 ((a) (bag (tagged-bag :coins
1299 (and (percentp 25) `(:cp ,(* 1000 (d 6))))
1300 (and (percentp 30) `(:sp ,(* 1000 (d 6))))
1301 (and (percentp 20) `(:ep ,(* 1000 (d 4))))
1302 (and (percentp 35) `(:gp ,(* 1000 (d 6 2))))
1303 (and (percentp 25) `(:pp ,(* 1000 (d 2)))))
1304 (and (percentp 50) (gems (d 6 6)))
1305 (and (percentp 50) (jewellery (d 6 6)))
1306 (and (percentp 10) (special (d 2)))
1307 (and (percentp 30) (magic :any 3))))
1308 ((b) (bag (tagged-bag :coins
1309 (and (percentp 50) `(:cp ,(* 1000 (d 8))))
1310 (and (percentp 25) `(:sp ,(* 1000 (d 6))))
1311 (and (percentp 25) `(:ep ,(* 1000 (d 4))))
1312 (and (percentp 35) `(:gp ,(* 1000 (d 3)))))
1313 (and (percentp 25) (gems (d 6)))
1314 (and (percentp 25) (jewellery (d 6)))
1316 (magic '(or :armour :missile :sword :weapon) 1))))
1317 ((c) (bag (tagged-bag :coins
1318 (and (percentp 20) `(:cp ,(* 1000 (d 12))))
1319 (and (percentp 30) `(:sp ,(* 1000 (d 4))))
1320 (and (percentp 10) `(:ep ,(* 1000 (d 4)))))
1321 (and (percentp 50) (gems (d 6 6)))
1322 (and (percentp 50) (jewellery (d 6 6)))
1323 (and (percentp 5) (special (d 2)))
1324 (and (percentp 10) (magic :any 2))))
1325 ((d) (bag (tagged-bag :coins
1326 (and (percentp 10) `(:cp ,(* 1000 (d 8))))
1327 (and (percentp 15) `(:sp ,(* 1000 (d 12))))
1328 (and (percentp 60) `(:gp ,(* 1000 (d 6)))))
1329 (and (percentp 30) (gems (d 8)))
1330 (and (percentp 30) (jewellery (d 8)))
1331 (and (percentp 10) (special (d 2)))
1332 (and (percentp 10) (magic :any 1 :potion 1))))
1333 ((e) (bag (tagged-bag :coins
1334 (and (percentp 5) `(:cp ,(* 1000 (d 10))))
1335 (and (percentp 30) `(:sp ,(* 1000 (d 12))))
1336 (and (percentp 25) `(:ep ,(* 1000 (d 4))))
1337 (and (percentp 25) `(:gp ,(* 1000 (d 8)))))
1338 (and (percentp 10) (gems (d 10)))
1339 (and (percentp 10) (jewellery (d 10)))
1340 (and (percentp 15) (special (d 2)))
1341 (and (percentp 25) (magic :any 3 :scroll 1))))
1342 ((f) (bag (tagged-bag :coins
1343 (and (percentp 30) `(:sp ,(* 1000 (d 10 2))))
1344 (and (percentp 20) `(:ep ,(* 1000 (d 8))))
1345 (and (percentp 45) `(:gp ,(* 1000 (d 12))))
1346 (and (percentp 30) `(:pp ,(* 1000 (d 3)))))
1347 (and (percentp 20) (gems (d 12 2)))
1348 (and (percentp 10) (jewellery (d 12)))
1349 (and (percentp 20) (special (d 3)))
1350 (and (percentp 30) (magic :potion 1 :scroll 1
1351 '(not :armour :missile
1352 :sword :weapon) 3))))
1353 ((g) (bag (tagged-bag :coins
1354 (and (percentp 50) `(:gp ,(* 10000 (d 4))))
1355 (and (percentp 50) `(:pp ,(* 1000 (d 6)))))
1356 (and (percentp 25) (gems (d 6 3)))
1357 (and (percentp 25) (jewellery (d 10)))
1358 (and (percentp 30) (special (d 3)))
1359 (and (percentp 35) (magic :any 4 :scroll 1))))
1360 ((h) (bag (tagged-bag :coins
1361 (and (percentp 25) `(:cp ,(* 1000 (d 8 3))))
1362 (and (percentp 50) `(:sp ,(* 1000 (d 100))))
1363 (and (percentp 50) `(:ep ,(* 10000 (d 4))))
1364 (and (percentp 50) `(:gp ,(* 10000 (d 6))))
1365 (and (percentp 25) `(:pp ,(* 1000 (d 4 5)))))
1366 (and (percentp 50) (gems (d 100)))
1367 (and (percentp 50) (jewellery (* 10 (d 4))))
1368 (and (percentp 10) (special (d 2)))
1369 (and (percentp 15) (magic :any 4 :potion 1 :scroll 1))))
1370 ((i) (bag (tagged-bag :coins
1371 (and (percentp 30) `(:pp ,(* 1000 (d 8)))))
1372 (and (percentp 50) (gems (d 6 2)))
1373 (and (percentp 50) (jewellery (d 6 2)))
1374 (and (percentp 5) (special (d 2)))
1375 (and (percentp 15) (magic :any 1))))
1376 ((j) (bag (tagged-bag :coins
1377 (and (percentp 25) `(:cp ,(* 1000 (d 4))))
1378 (and (percentp 10) `(:sp ,(* 1000 (d 3)))))))
1379 ((k) (bag (tagged-bag :coins
1380 (and (percentp 30) `(:sp ,(* 1000 (d 6))))
1381 (and (percentp 10) `(:ep ,(* 1000 (d 2)))))))
1382 ((l) (bag (and (percentp 50) (gems (d 4)))))
1383 ((m) (bag (and (percentp 55) (gems (d 4)))
1384 (and (percentp 45) (jewellery (d 6 2)))))
1385 ((n) (bag (and (percentp 10) (special (d 2)))
1386 (and (percentp 40) (magic :potion (d 4 2)))))
1387 ((o) (bag (and (percentp 10) (special (d 3)))
1388 (and (percentp 50) (magic :scroll (d 4)))))
1391 ((p) (bag (tagged-bag :coins `(:cp ,(d 8 3)))))
1392 ((q) (bag (tagged-bag :coins `(:sp ,(d 6 3)))))
1393 ((r) (bag (tagged-bag :coins `(:ep ,(d 6 2)))))
1394 ((s) (bag (tagged-bag :coins `(:gp ,(d 4 2)))
1395 (and (percentp 5) (gems 1))))
1396 ((t) (bag (tagged-bag :coins `(:pp ,(d 6 1)))
1397 (and (percentp 5) (gems 1))))
1398 ((u) (bag (tagged-bag :coins
1399 (and (percentp 10) `(:cp ,(d 100)))
1400 (and (percentp 10) `(:sp ,(d 100)))
1401 (and (percentp 5) `(:gp ,(d 100))))
1402 (and (percentp 5) (gems (d 2)))
1403 (and (percentp 5) (gems (d 4)))
1404 (and (percentp 2) (special 1))
1405 (and (percentp 2) (magic :any 1))))
1406 ((v) (bag (tagged-bag :coins
1407 (and (percentp 10) `(:sp ,(d 100)))
1408 (and (percentp 5) `(:ep ,(d 100)))
1409 (and (percentp 5) `(:gp ,(d 100)))
1410 (and (percentp 5) `(:pp ,(d 100))))
1411 (and (percentp 10) (gems (d 2)))
1412 (and (percentp 10) (gems (d 4)))
1413 (and (percentp 5) (special 1))
1414 (and (percentp 5) (magic :any 1))))
1416 ;; unguarded treasures
1418 (bag (tagged-bag :coins
1419 `(:sp ,(* 100 (d 6)))
1420 (and (percentp 50) `(:gp ,(* 10 (d 6)))))
1421 (and (percentp 5) (gems (d 6)))
1422 (and (percentp 2) (jewellery (d 6)))
1423 (and (percentp 2) (magic :any 1))))
1424 ((unguarded-2 unguarded-3)
1425 (bag (tagged-bag :coins
1426 `(:sp ,(* 100 (d 12)))
1427 (and (percentp 50) `(:gp ,(* 100 (d 6)))))
1428 (and (percentp 10) (gems (d 6)))
1429 (and (percentp 5) (jewellery (d 6)))
1430 (and (percentp 8) (magic :any 1))))
1431 ((unguarded-4 unguarded-5)
1432 (bag (tagged-bag :coins
1433 `(:sp ,(* 1000 (d 6)))
1434 `(:gp ,(* 200 (d 6))))
1435 (and (percentp 20) (gems (d 8)))
1436 (and (percentp 10) (jewellery (d 8)))
1437 (and (percentp 10) (magic :any 1))))
1438 ((unguarded-6 unguarded-7)
1439 (bag (tagged-bag :coins
1440 `(:sp ,(* 2000 (d 6)))
1441 `(:gp ,(* 500 (d 6))))
1442 (and (percentp 30) (gems (d 10)))
1443 (and (percentp 15) (jewellery (d 10)))
1444 (and (percentp 15) (magic :any 1))))
1445 ((unguarded-8 unguarded-9)
1446 (bag (tagged-bag :coins
1447 `(:sp ,(* 5000 (d 6)))
1448 `(:gp ,(* 1000 (d 6))))
1449 (and (percentp 40) (gems (d 12)))
1450 (and (percentp 20) (jewellery (d 12)))
1451 (and (percentp 20) (magic :any 1)))))))
1453 (defconstant combine-treasures
1457 (defun combine2 (spec a b)
1458 (labels ((comb (tag x y)
1460 (let ((label (car pair)))
1461 (when (or (eq label t)
1464 (let ((method (cdr pair)))
1466 (list (combine2 method x y))
1467 ((member +) (list (+ (car x) (car y))))
1468 ((or symbol function)
1469 (funcall method x y))))))))
1470 (error "No combiner found for ~S." tag)))
1473 (let* ((tag (car pair))
1474 (match (assoc tag b)))
1475 (push (if (null match)
1478 (comb tag (cdr pair) (cdr match))))
1481 (let* ((tag (car pair))
1482 (match (assoc tag a)))
1487 (defun combine (spec &rest lists)
1488 (reduce (lambda (x y) (combine2 spec x y)) lists))
1490 (defun treasure (types)
1493 (loop for type in types
1494 collect (treasure-type type))))
1496 (defun select-spells (table spells)
1497 (loop for n in spells
1498 for list across table
1499 collect (sort (loop repeat n collect (apply #'choose-uniformly list))