(t (run tag key)))
finally (return *dnd-alist*))))
+(defun percentp (pc) (< (random 100) pc))
+
+(defun bag (&rest things)
+ (loop for i in things
+ when i collect i))
+
+(defun tagged-bag (tag &rest things)
+ (let ((bag (apply #'bag things)))
+ (and bag (cons tag bag))))
+
+(defun choose (&rest things)
+ (let ((n 0)
+ (it nil))
+ (do ((things things (cddr things)))
+ ((null things) it)
+ (let ((k (car things)))
+ (incf n k)
+ (when (and (plusp n) (< (random n) k))
+ (setf it (cadr things)))))))
+
+(defun choose-uniformly (&rest things)
+ (let ((n 0) (it nil))
+ (do ((things things (cdr things)))
+ ((null things) it)
+ (incf n)
+ (when (< (random n) 1)
+ (setf it (car things))))))
+
+(defmacro pick (&rest clauses)
+ `(funcall (choose ,@(loop for (n . clause) in clauses
+ collect n
+ collect `(lambda () ,@clause)))))
+
+(defconstant druid-spells
+ #((detect-danger faerie-fire locate predict-weather)
+ (heat-metal obscure produce-fire warp-wood)
+ (call-lightning hold-animal protection-from-poison water-breathing)
+ (control-temperature-10-ft-radius plant-door protection-from-lightning
+ summon-animals)
+ (anti-plant-shell control-winds dissolve pass-plant)
+ (anti-animal-shell summon-weather transport-through-plants turn-wood)
+ (creeping-doom metal-to-wood summon-elemental weather-control)))
+
+(defconstant cleric-spells
+ #((cure-light-wounds detect-evil detect-magic light protection-from-evil
+ purify-food-and-water remove-fear resist-cold)
+ (bless find-traps hold-person resist-fire silence-15-ft-radius
+ slow-poison snake-charm speak-with-animal)
+ (continual-light cure-blindness cure-disease growth-of-animals
+ locate-object remove-curse speak-with-the-dead striking)
+ (animate-dead create-water cure-serious-wounds dispel-magic
+ neutralize-poison protection-from-evil-10-ft-radius speak-with-plants
+ sticks-to-snakes)
+ (commune create-food cure-critical-wounds dispel-evil insect-plague quest
+ raise-dead truesight)
+ (aerial-servant animate-objects barrier create-normal-animals cureall
+ find-the-path speak-with-monsters word-of-recall)
+ (earthquake holy-word raise-dead-fully restore survival travel wish
+ wizardry)))
+
+(defconstant magic-user-spells
+ #((analyse charm-person detect-magic floating-disc hold-portal light
+ magic-missile protection-from-evil read-languages read-magic shield
+ sleep ventriloquism)
+ (continual-light detect-evil detect-invisible entangle esp invisibility
+ knock levitate locate-object mirror-image phantasmal-force web
+ wizard-lock)
+ (clairvoyance create-air dispel-magic fire-ball fly haste hold-person
+ infravision invisibility-10-ft-radius lightning-bolt
+ protection-from-evil-10-ft-radius protection-from-normal-missiles
+ water-breathing)
+ (charm-monster clothform confusion dimension-door growth-of-plants
+ hallucinatory-terrain ice-storm/wall massmorph polymorph-others
+ polymorph-self remove-curse wall-of-fire wizard-eye)
+ (animate-dead cloudkill conjure-elemental contact-outer-plane dissolve
+ feeblemind hold-monster magic-jar pass-wall telekinesis teleport
+ wall-of-stone woodform)
+ (anti-magic-shell death-spell disintegrate geas invisible-stalker
+ lower-water move-earth projected-image reincarnation stone-to-flesh
+ stoneform wall-of-iron weather-control)
+ (charm-plant create-normal-monsters delayed-blast-fire-ball ironform lore
+ magic-door mass-invisibility power-word-stun reverse-gravity statue
+ summon-object sword teleport-any-object)
+ (clone create-magical-monsters dance explosive-cloud force-field
+ mass-charm mind-barrier permanence polymorph-any-object power-word-blind
+ steelform symbol travel)
+ (contingency create-any-monster gate heal immunity maze meteor-swarm
+ power-word-kill prismatic-wall shapechange survival timestop wish)))
+
+(defun spell-caster-type ()
+ (choose 25 :cleric 5 :druid 70 :magic-user))
+
+(defun random-spell (&optional (caster (spell-caster-type))
+ (level (ecase caster
+ ((:magic-user) (choose 28 1
+ 21 2
+ 15 3
+ 11 4
+ 9 5
+ 7 6
+ 5 7
+ 3 8
+ 1 9))
+ ((:cleric :druid) (choose 34 1
+ 24 2
+ 18 3
+ 12 4
+ 7 5
+ 4 6
+ 1 7)))))
+ (let ((list (aref (ecase caster
+ ((:magic-user) magic-user-spells)
+ ((:cleric) cleric-spells)
+ ((:druid) druid-spells))
+ level)))
+ (values (elt list (random (length list)))
+ caster
+ level)))
+
+(defun symbol-match-p (form sym)
+ (cond ((eq form t) t)
+ ((eq form nil) nil)
+ ((eq form sym) t)
+ ((atom form) nil)
+ (t (ecase (car form)
+ ((and) (every (lambda (f) (symbol-match-p f sym)) (cdr form)))
+ ((or) (some (lambda (f) (symbol-match-p f sym)) (cdr form)))
+ ((not) (not (symbol-match-p (cadr form) sym)))))))
+
+(defun choose-distinct-items (n seq)
+ (let* ((copy (subseq (coerce seq 'vector) 0))
+ (len (length copy))
+ (list nil))
+ (dotimes (i n (sort list #'string<))
+ (let ((j (random len)))
+ (push (aref copy j) list)
+ (decf len)
+ (setf (aref copy j) (aref copy len))))))
+
+(defun magic-item (form)
+ (labels ((potion (&key recursivep)
+ (pick (2 `(:potion agility))
+ (1 `(:potion animal-control))
+ (3 `(:potion antidote))
+ (2 `(:potion blending))
+ (2 `(:potion bug-repellent))
+ (2 `(:potion clairaudience))
+ (2 `(:potion clairvoyance))
+ (2 `(:potion climbing))
+ (2 `(:potion defence :bonus ,(choose 3 1
+ 2 2
+ 2 3
+ 2 4
+ 1 5)))
+ ((if recursivep 0 4)
+ `(:potion delusion
+ :fakes ,@(cdr (potion :recursivep t))))
+ (2 `(:potion diminution))
+ (1 `(:potion ,(choose 35 'white-dragon-control
+ 15 'crystal-dragon-control
+ 35 'black-dragon-control
+ 15 'onyx-dragon-control
+ 28 'green-dragon-control
+ 12 'jade-dragon-control
+ 21 'blue-dragon-control
+ 9 'sapphire-dragon-control
+ 14 'red-dragon-control
+ 6 'ruby-dragon-control
+ 7 'gold-dragon-control
+ 3 'amber-dragon-control)))
+ (2 `(:potion dreamspeech))
+ (1 `(:potion elasicity))
+ (2 `(:potion ,(choose-uniformly 'air-form
+ 'water-form
+ 'earth-form
+ 'fire-form)))
+ (2 `(:potion esp))
+ (1 `(:potion ethereality))
+ (3 `(:potion fire-resistance))
+ (3 `(:potion flying))
+ (2 `(:potion fortitude))
+ (1 `(:potion freedom))
+ (3 `(:potion gaseous-form))
+ (1 `(:potion ,(choose 5 'hill-giant-control
+ 5 'stone-giant-control
+ 4 'frost-giant-control
+ 2 'fire-giant-control
+ 1 'mountain-giant-control
+ 1 'sea-giant-control
+ 1 'cloud-giant-control
+ 1 'storm-giant-control)))
+ (3 `(:potion giant-strength))
+ (2 `(:potion growth))
+ (6 `(:potion healing))
+ (3 `(:potion heroism))
+ (1 `(:potion human-control))
+ (3 `(:potion invisibility))
+ (2 `(:potion invulnerability))
+ (2 `(:potion levitation))
+ (2 `(:potion longevity))
+ (1 `(:potion luck))
+ (1 `(:potion merging))
+ (2 `(:potion plant-control))
+ (3 `(:potion poison))
+ (3 `(:potion polymorph-self))
+ (2 `(:potion sight))
+ (2 `(:potion speech))
+ (4 `(:potion speed))
+ (2 `(:potion strength))
+ (3 `(:potion super-healing))
+ (3 `(:potion swimming))
+ (1 `(:potion treasure-finding))
+ (1 `(:potion undead-control))
+ (2 `(:potion water-breathing))))
+ (scroll ()
+ (pick (3 `(:scroll communication))
+ (2 `(:scroll creation))
+ (8 `(:scroll curse))
+ (1 (multiple-value-bind
+ (spell caster level)
+ (random-spell)
+ (declare (ignore level))
+ `(:scroll delay :caster ,caster :spells (,spell))))
+ (3 `(:scroll equipment
+ :items ,(choose-distinct-items 6
+ '(grappling-hook
+ hammer
+ iron-spikes
+ lantern
+ mirror
+ wooden-pole
+ rope
+ saddle
+ backpack
+ saddle-bags
+ stakes-and-mallet
+ wolfsbane))))
+ (2 `(:scroll illumination))
+ (2 `(:scroll mages))
+ (4 `(:map normal-treasure))
+ (3 `(:map magical-treasure))
+ (2 `(:map combined-treasure))
+ (1 `(:map special-treasure))
+ (3 `(:scroll mapping))
+ (2 `(:scroll portals))
+ (6 `(:scroll protection-from-elementals))
+ (8 `(:scroll protection-from-lycanthropes))
+ (4 `(:scroll protection-from-magic))
+ (7 `(:scroll protection-from-undead))
+ (2 `(:scroll questioning))
+ (1 (multiple-value-bind
+ (spell caster level)
+ (random-spell)
+ `(:scroll repetition
+ :caster ,caster
+ :level ,level
+ :spells (,spell))))
+ (2 `(:scroll seeing))
+ (2 `(:scroll shelter))
+ (3 `(:scroll spell-catching :max-level ,(choose 4 1
+ 3 2
+ 2 3
+ 1 8)))
+ (25 (let ((caster (spell-caster-type))
+ (spells (choose 50 1 33 2 17 3)))
+ `(:scroll spell
+ :caster ,caster
+ :spells ,(loop repeat spells
+ collect (random-spell caster)))))
+ (2 `(:scroll trapping))
+ (2 `(:scroll truth))))
+ (wand-charges () (d 10 3))
+ (staff-charges () (d 20 2))
+ (wandlike ()
+ (pick (5 `(:wand cold :charges ,(wand-charges)))
+ (5 `(:wand enemy-detection :charges ,(wand-charges)))
+ (4 `(:wand fear :charges ,(wand-charges)))
+ (5 `(:wand fireballs :charges ,(wand-charges)))
+ (4 `(:wand illusion :charges ,(wand-charges)))
+ (5 `(:wand lightning-bolts :charges ,(wand-charges)))
+ (5 `(:wand magic-detection :charges ,(wand-charges)))
+ (5 `(:wand metal-detection :charges ,(wand-charges)))
+ (4 `(:wand negation :charges ,(wand-charges)))
+ (5 `(:wand paralysation :charges ,(wand-charges)))
+ (5 `(:wand polymorphing :charges ,(wand-charges)))
+ (4 `(:wand secret-door-detection
+ :charges ,(wand-charges)))
+ (4 `(:wand trap-detection :charges ,(wand-charges)))
+ (1 `(:staff commanding :charges nil))
+ (2 `(:staff dispelling :charges ,(staff-charges)))
+ (3 `(:staff druids :charges ,(staff-charges)))
+ (3 `(:staff ,(choose 19 'air
+ 19 'earth
+ 19 'fire
+ 19 'water
+ 6 'air-and-water
+ 6 'earth-and-fire
+ 2 'elemental-power)
+ :charges ,(staff-charges)))
+ (2 `(:staff harming :charges ,(staff-charges)))
+ (7 `(:staff healing :charges ,(staff-charges)))
+ (1 `(:staff power :charges ,(staff-charges)))
+ (3 `(:staff snake :charges ,(staff-charges)))
+ (3 `(:staff striking :charges ,(staff-charges)))
+ (2 `(:staff withering :charges ,(staff-charges)))
+ (1 `(:staff wizardry :charges ,(staff-charges)))
+ (2 `(:rod cancellation))
+ (1 `(:rod dominion))
+ (1 `(:rod health))
+ (2 `(:rod inertia))
+ (1 `(:rod parrying))
+ (1 `(:rod victory))
+ (3 `(:rod weaponry))
+ (1 `(:rod wyrm :colour ,(choose 5 'gold
+ 3 'blue
+ 2 'black)))))
+ (ring ()
+ (pick (2 `(:ring animal-control))
+ (6 `(:ring delusion))
+ (1 `(:ring djinni-summoning))
+ (4 `(:ring ear))
+ (4 `(:ring ,(choose 19 'air-adaptation
+ 19 'earth-adaptation
+ 19 'fire-adaptation
+ 19 'water-adaptation
+ 6 'air-and-water-adaptation
+ 6 'earth-and-fire-adaptation
+ 2 'elemental-adaptation)))
+ (6 `(:ring fire-resistance))
+ (3 `(:ring holiness))
+ (1 `(:ring human-control))
+ (5 `(:ring invisibility))
+ (3 `(:ring life-protection :charges ,(d 6)))
+ (3 `(:ring memory))
+ (2 `(:ring plant-control))
+ (1 `(:ring protection :bonus 1 :radius 5))
+ (10 `(:ring protection :bonus ,(choose 4 1
+ 3 2
+ 2 3
+ 1 4)))
+ (4 `(:ring quickness))
+ (1 `(:ring regeneration))
+ (3 `(:ring remedies))
+ (2 `(:ring safety :charges ,(d 4)))
+ (3 `(:ring seeing))
+ (3 `(:ring spell-eating))
+ (2 (let* ((caster (spell-caster-type))
+ (spells (loop repeat (d 6)
+ collect (random-spell caster))))
+ `(:ring spell-storing
+ :caster ,caster
+ :spells ,(remove-duplicates (sort spells
+ #'string<)))))
+ (2 `(:ring spell-turning))
+ (4 `(:ring survival :charges ,(+ 100 (d 100))))
+ (2 `(:ring telekinesis))
+ (4 `(:ring truth))
+ (3 `(:ring truthfulness))
+ (2 `(:ring truthlessness))
+ (5 `(:ring water-walking))
+ (5 `(:ring weakness))
+ (2 `(:ring wishes :charges ,(choose 4 1
+ 3 2
+ 2 3
+ 1 4)))
+ (2 `(:ring x-ray-vision))))
+ (misc-item ()
+ (pick (2 `(:amulet protection-from-crystal-balls-and-esp))
+ (2 `(:bag devouring))
+ (5 `(:bag holding))
+ (3 `(:boat undersea))
+ (2 `(:boots levitation))
+ (3 `(:boots speed))
+ (2 `(:boots travelling-and-leaping))
+ (1 `(:bowl commanding-water-elementals))
+ (1 `(:brazier commanding-fire-elementals))
+ (2 `(:broom flying))
+ (1 `(:censer controlling-air-elementals))
+ (3 `(:chime time))
+ (2 `(:crystal-ball normal))
+ (1 `(:crystal-ball clairaudience))
+ (1 `(:crystal-ball esp))
+ (2 `(:cloak displacer))
+ (1 `(:drums panic))
+ (1 `(:bottle efreeti))
+ (3 `(:egg ,(choose-uniformly 'rock-baboon
+ 'giant-bat
+ 'black-bear
+ 'grizzly-bear
+ 'boar
+ 'mountain-lion
+ 'panther
+ 'giant-ferret
+ 'gecko
+ 'draco
+ 'racer-snake
+ 'wolf)))
+ (2 `(:boots elven))
+ (2 `(:cloak elven))
+ (1 `(:carpet flying))
+ (2 `(:gauntlets ogre-power))
+ (2 `(:girdle giant-strength))
+ (2 `(:helm ,(choose-uniformly 'lawful-alignment
+ 'neutral-alignment
+ 'chaotic-alignment)))
+ (2 `(:helm reading))
+ (1 `(:helm telepathy))
+ (1 `(:helm teleportation))
+ (1 `(:horn blasting))
+ (2 `(:lamp hurricane))
+ (3 `(:lamp long-burning))
+ (2 `(:medallion esp-30-ft-range))
+ (1 `(:medallion esp-90-ft-range))
+ (1 `(:mirror life-trapping)) ;;; fixme include contents
+ (3 `(:muzzle training))
+ (2 `(:nail finger))
+ (3 `(:nail pointing))
+ (5 `(:ointment ,(choose-uniformly 'blessing
+ 'healing
+ 'poison
+ 'scarring
+ 'soothing
+ 'tanning)))
+ (3 `(:pouch security))
+ (3 `(:quill copying))
+ (4 `(:rope climbing))
+ (2 `(:scarab protection :charges ,(d 6 2)))
+ (3 `(:slate identification))
+ (1 `(:stone controlling-earth-elementals))
+ (2 `(:talisman ,(choose-uniformly 'air-travel
+ 'earth-travel
+ 'fire-travel
+ 'water-travel
+ 'elemental-travel)))
+ (3 `(:wheel floating))
+ (1 `(:wheel fortune))
+ (2 `(:wheel square))))
+ (weapon-bonus (class)
+ (loop for bonus from 1
+ for roll = (random 100) then (- roll item)
+ for item in (ecase class
+ ((a) '(40 27 17 10 6))
+ ((b) '(50 24 14 8 4))
+ ((c) '(60 21 11 6 2))
+ ((d) '(70 18 8 3 1)))
+ when (< roll item) return bonus))
+ (armour-size ()
+ (choose 68 'human
+ 13 'dwarf
+ 10 'elf
+ 7 'halfling
+ 2 'giant))
+ (armour-piece (class)
+ (let* ((bonus (weapon-bonus class))
+ (power (and (percentp (* 5 (1+ bonus)))
+ (pick (7 `(absorption))
+ (10 `(charm))
+ (15 `(cure-wounds))
+ (10 `(electricity))
+ (5 `(energy-drain))
+ (3 `(ethereality))
+ (10 `(fly))
+ (6 `(gaseous-form))
+ (9 `(haste))
+ (10 `(invisibility))
+ (8 `(reflection))
+ (7 `(remove-curse :charges ,(d 3))))))
+ (cursedp (if (and power (eq (car power) 'remove-curse))
+ nil
+ (zerop (random 8)))))
+ `(:bonus ,bonus
+ ,@(and power (cons :power power))
+ :size ,(armour-size)
+ ,@(and cursedp `(:cursed t)))))
+ (armour ()
+ (pick (10 `((:leather ,@(armour-piece 'd))))
+ ( 7 `((:scale-mail ,@(armour-piece 'd))))
+ (13 `((:chain-mail ,@(armour-piece 'c))))
+ ( 9 `((:banded-mail ,@(armour-piece 'd))))
+ (11 `((:plate-mail ,@(armour-piece 'b))))
+ ( 5 `((:suit-armour ,@(armour-piece 'b))))
+ (20 `((:shield ,@(armour-piece 'a))))
+ ( 2 `((:scale-mail ,@(armour-piece 'd))
+ (:shield ,@(armour-piece 'a))))
+ ( 8 `((:chain-mail ,@(armour-piece 'c))
+ (:shield ,@(armour-piece 'a))))
+ ( 5 `((:banded-mail ,@(armour-piece 'd))
+ (:shield ,@(armour-piece 'a))))
+ (10 `((:plate-mail ,@(armour-piece 'b))
+ (:shield ,@(armour-piece 'a))))))
+ (opponent ()
+ (choose 6 'bugs
+ 3 'constructs
+ 6 'dragonkind
+ 9 'enchanted-monsters
+ 12 'giantkind
+ 12 'lycanthropes
+ 4 'planar-monsters
+ 6 'regenerating-monsters
+ 9 'reptiles-and-dinosaurs
+ 3 'spell-immune-monsters
+ 6 'spellcasters
+ 12 'undead
+ 6 'water-breathing-monsters
+ 6 'weapon-using-monsters))
+ (weapon-talent (&key missilep)
+ (pick (5 `(breathing))
+ (7 `(charming))
+ (4 `(deceiving))
+ ((if missilep 0 7) `(defending))
+ (2 `(deflecting))
+ (2 `(draining :charges ,(+ 4 (d 4))))
+ (5 `(extinguishing))
+ (6 `(finding))
+ (5 `(flaming))
+ (3 `(flying))
+ (8 `(healing))
+ (5 `(hiding))
+ (6 `(holding))
+ (8 `(lightning))
+ (6 `(silencing))
+ (2 `(slicing))
+ (4 `(slowing))
+ (4 `(speeding))
+ (5 `(translating))
+ (5 `(watching))
+ (1 `(wishing :charges ,(d 3)))))
+ (weapon-modifier (bonus &rest keys &key &allow-other-keys)
+ (and (percentp (aref #(40 30 20 15 10) (1- bonus)))
+ (pick (33 `(:extra (,(+ bonus 1) :against ,(opponent))))
+ (24 `(:extra (,(+ bonus 2) :against ,(opponent))))
+ (16 `(:extra (,(+ bonus 3) :against ,(opponent))))
+ (9 `(:extra (,(+ bonus 4) :against ,(opponent))))
+ (3 `(:extra (,(+ bonus 5) :against ,(opponent))))
+ (15 `(:talent ,@(apply #'weapon-talent keys))))))
+ (sword-modifier (bonus &rest keys &key &allow-other-keys)
+ (and (percentp (aref #(40 30 25 20 15) (1- bonus)))
+ (pick (29 `(:extra (,(+ bonus 1) :against ,(opponent))))
+ (21 `(:extra (,(+ bonus 2) :against ,(opponent))))
+ (14 `(:extra (,(+ bonus 3) :against ,(opponent))))
+ (8 `(:extra (,(+ bonus 4) :against ,(opponent))))
+ (3 `(:extra (,(+ bonus 5) :against ,(opponent))))
+ (25 `(:talent ,@(apply #'weapon-talent keys))))))
+ (missile ()
+ (multiple-value-bind
+ (item class)
+ (pick (37 (values :arrow 'a))
+ (22 (values :quarrel 'a))
+ (11 (values :sling-stone 'a))
+ (2 (values :blowgun 'd))
+ (8 (values :long-bow 'd))
+ (5 (values :short-bow 'd))
+ (2 (values :heavy-crossbow 'd))
+ (5 (values :light-crossbow 'd))
+ (8 (values :sling 'd)))
+ (ecase class
+ ((a) (let* ((bonus (weapon-bonus 'a))
+ (cursedp (zerop (random 10)))
+ (talent (and (percentp (* 5 (- 7 bonus)))
+ (choose 4 'biting
+ 5 'blinking
+ 5 'charming
+ 7 'climbing
+ 10 'curing
+ 3 'disarming
+ 4 'dispelling
+ 7 'flying
+ 7 'lightning
+ 5 'penetrating
+ 4 'refilling
+ 6 'screaming
+ 5 'seeking
+ 4 'sinking
+ 2 'slaying
+ 7 'speaking
+ 4 'stunning
+ 2 'teleporting
+ 5 'transporting
+ 4 'wounding)))
+ (number (ecase bonus
+ ((1) (d 10 2))
+ ((2) (d 8 2))
+ ((3) (d 6 2))
+ ((4) (d 4 2))
+ ((5) (+ (d 4) 1)))))
+ `(,item :bonus ,bonus
+ ,@(and talent `(:talent ,talent))
+ :number ,number
+ ,@(and cursedp `(:cursed t)))))
+ ((d) (let* ((bonus (weapon-bonus 'd))
+ (cursedp (zerop (random 10)))
+ (modifier (weapon-modifier bonus :missilep t))
+ (range (ecase (+ bonus (d 4))
+ ((2 3 4) nil)
+ ((5 6 7) 1.5)
+ ((8 9) 2))))
+ `(,item :bonus ,bonus ,@modifier
+ ,@(and range `(:range ,range))
+ ,@(and cursedp `(:cursed t))))))))
+ (weapon-intelligence ()
+ (multiple-value-bind
+ (int langs prim read-magic-p extra)
+ (pick (79 (values nil 0 0 nil 0))
+ (6 (values 7 0 1 nil 0))
+ (5 (values 8 0 2 nil 0))
+ (4 (values 9 0 3 nil 0))
+ (3 (values 10 (d 3) 3 nil 0))
+ (2 (values 11 (d 6) 3 t 0))
+ (1 (values 12 (d 4 2) 3 t 1)))
+ (and int
+ (let ((powers nil)
+ (healing nil)
+ (damage nil)
+ (checklist nil))
+ (macrolet ((power-check (&rest forms)
+ `(pick ,@(loop for (tag n . form) in forms
+ if tag
+ collect
+ `((if (member ',tag
+ checklist)
+ 0
+ ,n)
+ (push ',tag checklist)
+ ,@(or form
+ `((push ',tag
+ powers))))
+ else
+ collect `(,n ,@form)))))
+ (labels ((primary-power ()
+ (power-check
+ (detect-evil 10)
+ (detect-gems 5)
+ (detect-magic 10)
+ (detect-metal 10)
+ (detect-shifting-walls-and-rooms 15)
+ (detect-sloping-passages 15)
+ (find-secret-doors 10)
+ (find-traps 10)
+ (see-invisible 10)
+ (:one-extra 4
+ (extraordinary-power))
+ (:two-primary 1
+ (primary-power)
+ (primary-power))))
+ (extraordinary-power ()
+ (power-check
+ (clairaudience 10)
+ (clairvoyance 10)
+ (esp 10)
+ (nil 5
+ (setf damage (if damage
+ (1+ damage)
+ 5)))
+ (flying 5)
+ (nil 5
+ (setf healing (+ (or healing 0) 6)))
+ (illusion 9)
+ (levitation 5)
+ (telekinesis 10)
+ (telepathy 10)
+ (teleportation 9)
+ (x-ray-vision 9)
+ (:two-three-extra 2
+ (extraordinary-power)
+ (extraordinary-power))
+ (:two-three-extra 1
+ (extraordinary-power)
+ (extraordinary-power)
+ (extraordinary-power)))))
+ (dotimes (i prim) (primary-power))
+ (dotimes (i extra) (extraordinary-power))))
+ (when damage
+ (push `(extra-damage ,damage) powers))
+ (when healing
+ (push `(healing ,healing) powers))
+ `(:intelligence ,int
+ :ego ,(d 12)
+ :languages ,langs
+ ,@(and read-magic-p `(:read-magic t))
+ :powers ,powers)))))
+ (sword ()
+ (multiple-value-bind
+ (type class)
+ (pick (65 (values :normal-sword 'c))
+ (19 (values :short-sword 'c))
+ (8 (values :two-handed-sword 'd))
+ (8 (values :bastard-sword 'd)))
+ (let* ((bonus (weapon-bonus class))
+ (cursedp (zerop (random 10)))
+ (modifier (sword-modifier bonus))
+ (intel (weapon-intelligence)))
+ `(,type :bonus ,bonus
+ ,@modifier
+ ,@intel
+ ,@(and cursedp `(:cursed t))))))
+ (weapon ()
+ (multiple-value-bind
+ (type returnsp class)
+ (pick (7 (values :battle-axe nil 'd))
+ (8 (values :hand-axe (choose 3 nil 1 t) 'b))
+ (3 (values :blackjack nil 'c))
+ (3 (values :bola (choose 2 nil 1 t) 'b))
+ (5 (values :club nil 'c))
+ (14 (values :dagger (choose 11 nil 3 t) 'b))
+ (4 (values :one-handed-flail nil 'c))
+ (2 (values :two-handed-flail nil 'd))
+ (3 (values :halberd nil 'd))
+ (8 (values :war-hammer nil 'c))
+ (4 (values :javelin (choose 3 nil 1 t) 'b))
+ (4 (values :lance nil 'd))
+ (7 (values :mace nil 'c))
+ (5 (values :morning-star nil 'c))
+ (3 (values :net (choose 2 nil 1 t) 'b))
+ (3 (values :pike nil 'd))
+ (2 (values :pole-axe nil 'd))
+ (12 (values :spear (choose 3 nil 1 t) 'b))
+ (3 (values :whip nil 'c)))
+ (let* ((bonus (weapon-bonus class))
+ (cursedp (zerop (random 10)))
+ (modifier (sword-modifier bonus))
+ (intel (and (percentp 40)
+ (weapon-intelligence))))
+ `(,type
+ ,@(and returnsp `(:returning t))
+ :bonus ,bonus
+ ,@modifier
+ ,@intel
+ ,@(and cursedp `(:cursed t)))))))
+ (pick ((if (symbol-match-p form :potion) 25 0) (list (potion)))
+ ((if (symbol-match-p form :scroll) 12 0) (list (scroll)))
+ ((if (symbol-match-p form :wandlike) 9 0) (list (wandlike)))
+ ((if (symbol-match-p form :ring) 6 0) (list (ring)))
+ ((if (symbol-match-p form :misc) 10 0) (list (misc-item)))
+ ((if (symbol-match-p form :armour) 10 0) (armour))
+ ((if (symbol-match-p form :missile) 11 0) (list (missile)))
+ ((if (symbol-match-p form :sword) 9 0) (list (sword)))
+ ((if (symbol-match-p form :weapon) 8 0) (list (weapon))))))
+
+(defun treasure-type (type-code)
+ (labels ((common-fur-type ()
+ (choose-uniformly 'beaver
+ 'fox
+ 'marten
+ 'seal))
+ (rare-fur-type ()
+ (choose-uniformly 'ermine
+ 'mink
+ 'sable))
+ (special (n)
+ (tagged-bag
+ :special
+ (loop repeat n
+ collect
+ (pick (10 `(:kind book
+ :value ,(* 10 (d 100))
+ :encumbrance ,(d 100)))
+ (2 `(:kind pelt
+ :animal ,(common-fur-type)
+ :value ,(d 4)
+ :encumbrance ,(* 10 (d 6))))
+ (5 `(:kind cape
+ :animal ,(common-fur-type)
+ :value ,(* 100 (d 6))
+ :encumbrance ,(* 10 (+ 4 (d 8)))))
+ (3 `(:kind coat
+ :animal ,(common-fur-type)
+ :value ,(* 100 (d 4 3))
+ :encumbrance ,(* 10 (+ 8 (d 6 2)))))
+ (2 `(:kind pelt
+ :animal ,(rare-fur-type)
+ :value ,(d 6 2)
+ :encumbrance ,(* 10 (d 6))))
+ (5 `(:kind cape
+ :animal ,(rare-fur-type)
+ :value ,(* 100 (d 6 4))
+ :encumbrance ,(* 10 (+ 4 (d 8)))))
+ (3 `(:kind coat
+ :animal ,(rare-fur-type)
+ :value ,(* 1000 (d 4))
+ :encumbrance ,(* 10 (+ 8 (d 6 2)))))
+ (5 `(:kind incense
+ :value ,(d 6 5)
+ :encumbrance 1
+ :quantity ,(d 4 2)))
+ (5 `(:kind perfume
+ :value ,(* 10 (+ 5 (d 10)))
+ :encumbrance 1
+ :quantity ,(d 3 2)))
+ (5 (let ((w (d 6)) (h (d 2)))
+ `(:kind ,(choose-uniformly 'rug
+ 'tapestry)
+ :value ,(* w h (d 10 2))
+ :encumbrance ,(* 100 w h (d 6))
+ :size (* ,w ,h))))
+ (10 (let ((w (d 8)) (h (d 2)))
+ `(:kind silk
+ :value ,(* w h (d 8))
+ :encumbrance ,(* 10 w h (d 6))
+ :size (* ,w ,h))))
+ (10 `(:kind animal-skin
+ :value ,(d 10)
+ :encumbrance ,(* 10 (d 4 5))))
+ (10 `(:kind monster-skin
+ :value ,(* 100 (d 10))
+ :encumbrance ,(* 50 (d 100))))
+ (5 (let ((enc (d 100)))
+ `(:kind spice
+ :value ,(* enc (d 4 4))
+ :encumbrance ,enc)))
+ (5 `(:kind statuette
+ :value ,(* 100 (d 10))
+ :encumbrance ,(d 100)))
+ (5 `(:wine
+ :value ,(d 6)
+ :encumbrance ,(* 10 (+ 3 (d 6)))
+ :bottles ,(d 12)))))))
+ (gem-type (&key (min-value 0) recursivep)
+ (pick ((if (<= min-value 10) 3 0)
+ (values 10 (choose-uniformly 'agate
+ 'quartz
+ 'turquoise)))
+ ((if (<= min-value 50) 7 0)
+ (values 50 (choose-uniformly 'crystal
+ 'jasper
+ 'onyx)))
+ ((if (<= min-value 100) 15 0)
+ (values 100 (choose-uniformly 'amber
+ 'amethyst
+ 'coral
+ 'garnet
+ 'jade)))
+ ((if (<= min-value 500) 21 0)
+ (values 500 (choose-uniformly 'aquamarine
+ 'pearl
+ 'topaz)))
+ ((if (<= min-value 1000) 25 0)
+ (values 1000 (choose-uniformly 'carbuncle
+ 'opal)))
+ ((if (<= min-value 5000) 19 0)
+ (values 5000 (choose-uniformly 'emerald
+ 'ruby
+ 'sapphire)))
+ ((if (<= min-value 10000) 7 0)
+ (values 10000 'diamond 'jacinth))
+ ((if (<= min-value 1000) 1 0)
+ (values (* 1000 (d 100))
+ 'tristal))
+ ((if (and (not recursivep)
+ (<= min-value 2000)) 2 0)
+ (multiple-value-bind
+ (value kind)
+ (gem-type :min-value (max 1000
+ (ceiling min-value 2))
+ :recursivep t)
+ (values (* 2 value)
+ (intern (format nil "STAR-~A"
+ (string kind))))))))
+ (gems (n)
+ (tagged-bag
+ :gems
+ (loop while (plusp n)
+ for i = (min n (d 5))
+ do (decf n i)
+ collect
+ (let ((mods (choose 4 :size 4 :qual 2 :both))
+ (mod-list nil))
+ (multiple-value-bind
+ (value kind)
+ (gem-type)
+ (when (or (eq mods :size)
+ (eq mods :both))
+ (multiple-value-bind
+ (mod mult)
+ (pick (1 (values 'very-small 1/8))
+ (2 (values 'small 1/4))
+ (2 (values 'fairly-small 1/2))
+ (2 (values 'fairly-large 2))
+ (2 (values 'large 4))
+ (1 (values 'very-small 8)))
+ (setf mod-list
+ (append `(:size ,mod) mod-list))
+ (setf value (* value mult))))
+ (when (or (eq mods :qual)
+ (eq mods :both))
+ (multiple-value-bind
+ (mod mult)
+ (pick (1 (values 'very-poor 1/8))
+ (2 (values 'poor 1/4))
+ (2 (values 'fairly-poor 1/2))
+ (2 (values 'fairly-good 2))
+ (2 (values 'good 4))
+ (1 (values 'very-good 8)))
+ (setf mod-list
+ (append `(:size ,mod) mod-list))
+ (setf value (* value mult))))
+ `(:kind ,kind
+ :value ,(max 1 (round value))
+ ,@mod-list
+ ,@(and (> i 1) `(:quantity ,i))))))))
+ (jewellery (n)
+ (tagged-bag
+ :jewellery
+ (loop while (plusp n)
+ for i = (min n (d 5))
+ do (decf n i)
+ collect
+ (multiple-value-bind
+ (value enc class)
+ (pick ( 1 (values 100 10 'a))
+ ( 2 (values 500 10 'a))
+ ( 3 (values 1000 10 'a))
+ ( 4 (values 1500 10 'a))
+ ( 5 (values 2000 10 'a))
+ ( 8 (values 2500 10 'a))
+ (10 (values 3000 25 'a))
+ (11 (values 4000 25 'b))
+ (13 (values 5000 25 'b))
+ (11 (values 7500 25 'b))
+ ( 9 (values 10000 25 'b))
+ ( 7 (values 15000 25 'c))
+ ( 5 (values 20000 50 'c))
+ ( 4 (values 25000 50 'c))
+ ( 3 (values 30000 50 'c))
+ ( 2 (values 40000 50 'c))
+ ( 1 (values 50000 50 'c)))
+ (let ((kind (ecase class
+ ((a) (choose-uniformly 'anklet
+ 'beads
+ 'bracelet
+ 'brooch
+ 'buckle
+ 'cameo
+ 'chain
+ 'clasp
+ 'locket
+ 'pin))
+ ((b) (choose-uniformly 'armband
+ 'belt
+ 'collar
+ 'earring
+ 'four-leaf-clover
+ 'heart
+ 'leaf
+ 'necklace
+ 'pendant
+ 'rabbit-foot))
+ ((c) (choose-uniformly 'amulet
+ 'crown
+ 'diadem
+ 'medallion
+ 'orb
+ 'ring
+ 'scarab
+ 'sceptre
+ 'talisman
+ 'tiara)))))
+ `(:kind ,kind
+ :value ,value
+ :encumbrance ,enc
+ ,@(and (> i 1) `(:quantity ,i))))))))
+ (magic (&rest forms)
+ (tagged-bag :magic
+ (loop with list = nil
+ for (form n) on forms by #'cddr do
+ (loop repeat n do
+ (dolist (item (magic-item form))
+ (push item list)))
+ finally (return list)))))
+ (ecase type-code
+
+ ;; treasure in lair
+ ((a) (bag (tagged-bag :coins
+ (and (percentp 25) `(:cp ,(* 1000 (d 6))))
+ (and (percentp 30) `(:sp ,(* 1000 (d 6))))
+ (and (percentp 20) `(:ep ,(* 1000 (d 4))))
+ (and (percentp 35) `(:gp ,(* 1000 (d 6 2))))
+ (and (percentp 25) `(:pp ,(* 1000 (d 2)))))
+ (and (percentp 50) (gems (d 6 6)))
+ (and (percentp 50) (jewellery (d 6 6)))
+ (and (percentp 10) (special (d 2)))
+ (and (percentp 30) (magic t 3))))
+ ((b) (bag (tagged-bag :coins
+ (and (percentp 50) `(:cp ,(* 1000 (d 8))))
+ (and (percentp 25) `(:sp ,(* 1000 (d 6))))
+ (and (percentp 25) `(:ep ,(* 1000 (d 4))))
+ (and (percentp 35) `(:gp ,(* 1000 (d 3)))))
+ (and (percentp 25) (gems (d 6)))
+ (and (percentp 25) (jewellery (d 6)))
+ (and (percentp 10)
+ (magic '(or :armour :missile :sword :weapon) 1))))
+ ((c) (bag (tagged-bag :coins
+ (and (percentp 20) `(:cp ,(* 1000 (d 12))))
+ (and (percentp 30) `(:sp ,(* 1000 (d 4))))
+ (and (percentp 10) `(:ep ,(* 1000 (d 4)))))
+ (and (percentp 50) (gems (d 6 6)))
+ (and (percentp 50) (jewellery (d 6 6)))
+ (and (percentp 5) (special (d 2)))
+ (and (percentp 10) (magic t 2))))
+ ((d) (bag (tagged-bag :coins
+ (and (percentp 10) `(:cp ,(* 1000 (d 8))))
+ (and (percentp 15) `(:sp ,(* 1000 (d 12))))
+ (and (percentp 60) `(:gp ,(* 1000 (d 6)))))
+ (and (percentp 30) (gems (d 8)))
+ (and (percentp 30) (jewellery (d 8)))
+ (and (percentp 10) (special (d 2)))
+ (and (percentp 10) (magic t 1 :potion 1))))
+ ((e) (bag (tagged-bag :coins
+ (and (percentp 5) `(:cp ,(* 1000 (d 10))))
+ (and (percentp 30) `(:sp ,(* 1000 (d 12))))
+ (and (percentp 25) `(:ep ,(* 1000 (d 4))))
+ (and (percentp 25) `(:gp ,(* 1000 (d 8)))))
+ (and (percentp 10) (gems (d 10)))
+ (and (percentp 10) (jewellery (d 10)))
+ (and (percentp 15) (special (d 2)))
+ (and (percentp 25) (magic t 3 :scroll 1))))
+ ((f) (bag (tagged-bag :coins
+ (and (percentp 30) `(:sp ,(* 1000 (d 10 2))))
+ (and (percentp 20) `(:ep ,(* 1000 (d 8))))
+ (and (percentp 45) `(:gp ,(* 1000 (d 12))))
+ (and (percentp 30) `(:pp ,(* 1000 (d 3)))))
+ (and (percentp 20) (gems (d 12 2)))
+ (and (percentp 10) (jewellery (d 12)))
+ (and (percentp 20) (special (d 3)))
+ (and (percentp 30) (magic :potion 1 :scroll 1
+ '(not :armour :missile
+ :sword :weapon) 3))))
+ ((g) (bag (tagged-bag :coins
+ (and (percentp 50) `(:gp ,(* 10000 (d 4))))
+ (and (percentp 50) `(:pp ,(* 1000 (d 6)))))
+ (and (percentp 25) (gems (d 6 3)))
+ (and (percentp 25) (jewellery (d 10)))
+ (and (percentp 30) (special (d 3)))
+ (and (percentp 35) (magic t 4 :scroll 1))))
+ ((h) (bag (tagged-bag :coins
+ (and (percentp 25) `(:cp ,(* 1000 (d 8 3))))
+ (and (percentp 50) `(:sp ,(* 1000 (d 100))))
+ (and (percentp 50) `(:ep ,(* 10000 (d 4))))
+ (and (percentp 50) `(:gp ,(* 10000 (d 6))))
+ (and (percentp 25) `(:pp ,(* 1000 (d 4 5)))))
+ (and (percentp 50) (gems (d 100)))
+ (and (percentp 50) (jewellery (* 10 (d 4))))
+ (and (percentp 10) (special (d 2)))
+ (and (percentp 15) (magic t 4 :potion 1 :scroll 1))))
+ ((i) (bag (tagged-bag :coins
+ (and (percentp 30) `(:pp ,(* 1000 (d 8)))))
+ (and (percentp 50) (gems (d 6 2)))
+ (and (percentp 50) (jewellery (d 6 2)))
+ (and (percentp 5) (special (d 2)))
+ (and (percentp 15) (magic t 1))))
+ ((j) (bag (tagged-bag :coins
+ (and (percentp 25) `(:cp ,(* 1000 (d 4))))
+ (and (percentp 10) `(:sp ,(* 1000 (d 3)))))))
+ ((k) (bag (tagged-bag :coins
+ (and (percentp 30) `(:sp ,(* 1000 (d 6))))
+ (and (percentp 10) `(:ep ,(* 1000 (d 2)))))))
+ ((l) (bag (and (percentp 50) (gems (d 4)))))
+ ((m) (bag (and (percentp 55) (gems (d 4)))
+ (and (percentp 45) (jewellery (d 6 2)))))
+ ((n) (bag (and (percentp 10) (special (d 2)))
+ (and (percentp 40) (magic :potion (d 4 2)))))
+ ((o) (bag (and (percentp 10) (special (d 3)))
+ (and (percentp 50) (magic :scroll (d 4)))))
+
+ ;; treasure carried
+ ((p) (bag (tagged-bag :coins `(:cp ,(d 8 3)))))
+ ((q) (bag (tagged-bag :coins `(:sp ,(d 6 3)))))
+ ((r) (bag (tagged-bag :coins `(:ep ,(d 6 2)))))
+ ((s) (bag (tagged-bag :coins `(:gp ,(d 4 2)))
+ (and (percentp 5) (gems 1))))
+ ((t) (bag (tagged-bag :coins `(:pp ,(d 6 1)))
+ (and (percentp 5) (gems 1))))
+ ((u) (bag (tagged-bag :coins
+ (and (percentp 10) `(:cp ,(d 100)))
+ (and (percentp 10) `(:sp ,(d 100)))
+ (and (percentp 5) `(:gp ,(d 100))))
+ (and (percentp 5) (gems (d 2)))
+ (and (percentp 5) (gems (d 4)))
+ (and (percentp 2) (special 1))
+ (and (percentp 2) (magic t 1))))
+ ((v) (bag (tagged-bag :coins
+ (and (percentp 10) `(:sp ,(d 100)))
+ (and (percentp 5) `(:ep ,(d 100)))
+ (and (percentp 5) `(:gp ,(d 100)))
+ (and (percentp 5) `(:pp ,(d 100))))
+ (and (percentp 10) (gems (d 2)))
+ (and (percentp 10) (gems (d 4)))
+ (and (percentp 5) (special 1))
+ (and (percentp 5) (magic t 1))))
+
+ ;; unguarded treasures
+ ((unguarded-1)
+ (bag (tagged-bag :coins
+ `(:sp ,(* 100 (d 6)))
+ (and (percentp 50) `(:gp ,(* 10 (d 6)))))
+ (and (percentp 5) (gems (d 6)))
+ (and (percentp 2) (jewellery (d 6)))
+ (and (percentp 2) (magic t 1))))
+ ((unguarded-2 unguarded-3)
+ (bag (tagged-bag :coins
+ `(:sp ,(* 100 (d 12)))
+ (and (percentp 50) `(:gp ,(* 100 (d 6)))))
+ (and (percentp 10) (gems (d 6)))
+ (and (percentp 5) (jewellery (d 6)))
+ (and (percentp 8) (magic t 1))))
+ ((unguarded-4 unguarded-5)
+ (bag (tagged-bag :coins
+ `(:sp ,(* 1000 (d 6)))
+ `(:gp ,(* 200 (d 6))))
+ (and (percentp 20) (gems (d 8)))
+ (and (percentp 10) (jewellery (d 8)))
+ (and (percentp 10) (magic t 1))))
+ ((unguarded-6 unguarded-7)
+ (bag (tagged-bag :coins
+ `(:sp ,(* 2000 (d 6)))
+ `(:gp ,(* 500 (d 6))))
+ (and (percentp 30) (gems (d 10)))
+ (and (percentp 15) (jewellery (d 10)))
+ (and (percentp 15) (magic t 1))))
+ ((unguarded-8 unguarded-9)
+ (bag (tagged-bag :coins
+ `(:sp ,(* 5000 (d 6)))
+ `(:gp ,(* 1000 (d 6))))
+ (and (percentp 40) (gems (d 12)))
+ (and (percentp 20) (jewellery (d 12)))
+ (and (percentp 20) (magic t 1)))))))
~mdw / dnd / blobdiff