chiark - git - mdw - dnd/blob - dice.lisp

   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
 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 (&body clauses)
 182   `(funcall (choose ,@(loop for (n . clause) in clauses
 183                            collect n
 184                            collect `(lambda () ,@clause)))))
 185
 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)
 191                                    ,prob
 192                                    0)
 193                                ,@code))))))
 194
 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
 204      sticks-to-snakes)
 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
 210      wizardry)))
 211
 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
 217      summon-animals)
 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)))
 221
 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))))
 226
 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
 230      sleep ventriloquism)
 231     (continual-light detect-evil detect-invisible entangle esp invisibility
 232      knock levitate locate-object mirror-image phantasmal-force web
 233      wizard-lock)
 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
 237      water-breathing)
 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)))
 255
 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)))
 261
 262 (defun random-spell (&optional (caster (spell-caster-type))
 263                                (level (ecase caster
 264                                         ((:magic-user) (choose 28 1
 265                                                                21 2
 266                                                                15 3
 267                                                                11 4
 268                                                                 9 5
 269                                                                 7 6
 270                                                                 5 7
 271                                                                 3 8
 272                                                                 1 9))
 273                                         ((:cleric :druid) (choose 34 1
 274                                                                   24 2
 275                                                                   18 3
 276                                                                   12 4
 277                                                                    7 5
 278                                                                    4 6
 279                                                                    1 7)))))
 280   (let ((list (aref (ecase caster
 281                       ((:magic-user) magic-user-spells)
 282                       ((:cleric) cleric-spells)
 283                       ((:druid) druid-only-spells))
 284                     level)))
 285     (values (elt list (random (length list)))
 286             caster
 287             level)))
 288
 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)))
 296           (t (case (car form)
 297                ((and) (every (lambda (f)
 298                                (assertion-match-p f assertions))
 299                              (cdr form)))
 300                ((or) (some (lambda (f)
 301                              (assertion-match-p f assertions))
 302                            (cdr form)))
 303                ((not) (not (assertion-match-p (cadr form) assertions)))
 304                (t (let ((sub (getf assertions (car form) magic)))
 305                     (if (eq sub magic)
 306                         t
 307                         (assertion-match-p (cadr form) sub)))))))))
 308
 309 (defun choose-distinct-items (n seq)
 310   (let* ((copy (subseq (coerce seq 'vector) 0))
 311          (len (length copy))
 312          (list nil))
 313     (dotimes (i n (sort list #'string<))
 314       (let ((j (random len)))
 315         (push (aref copy j) list)
 316         (decf len)
 317         (setf (aref copy j) (aref copy len))))))
 318
 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))
 324                     nil)
 325                    (t t)))
 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
 337                                                                   2 2
 338                                                                   2 3
 339                                                                   2 4
 340                                                                   1 5)))
 341                ((if recursivep 0 4) (:cursed t)
 342                 (setf form :any)
 343                 `(:potion delusion
 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
 361                                                              'water-form
 362                                                              'earth-form
 363                                                              'fire-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
 376                                                    1 'sea-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))))
 402            (scroll ()
 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)
 408                    :cursed nil)
 409                   (multiple-value-bind
 410                       (spell caster level)
 411                       (random-spell (spell-caster-type form))
 412                     (declare (ignore level))
 413                     `(:scroll delay :caster ,caster :spells (,spell))))
 414                (3 (:cursed nil)
 415                   `(:scroll equipment
 416                     :items ,(choose-distinct-items 6
 417                                                    '(grappling-hook
 418                                                      hammer
 419                                                      iron-spikes
 420                                                      lantern
 421                                                      mirror
 422                                                      wooden-pole
 423                                                      rope
 424                                                      saddle
 425                                                      backpack
 426                                                      saddle-bags
 427                                                      stakes-and-mallet
 428                                                      wolfsbane))))
 429                (2 (:cursed nil) `(:scroll illumination))
 430                (2 (:cursed nil :user (:magic-user :cleric :druid :elf))
 431                   `(:scroll mages))
 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))
 443                (1 (:cursed nil
 444                    :user (:cleric :druid :magic-user :elf :thief :paladin))
 445                   (multiple-value-bind
 446                       (spell caster level)
 447                       (random-spell (spell-caster-type form))
 448                     `(:scroll repetition
 449                       :caster ,caster
 450                       :level ,level
 451                       :spells (,spell))))
 452                (2 (:cursed nil) `(:scroll seeing))
 453                (2 (:cursed nil) `(:scroll shelter))
 454                (3 (:cursed nil)
 455                   `(:scroll spell-catching :max-level ,(choose 4 1
 456                                                                3 2
 457                                                                2 3
 458                                                                1 8)))
 459                (25 (:cursed nil
 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)))
 463                      `(:scroll spell
 464                        :caster ,caster
 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))
 471            (wandlike ()
 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))
 501                (2 nil
 502                   `(:staff dispelling :charges ,(staff-charges)))
 503                (3 (:user :druid)
 504                   `(:staff druids :charges ,(staff-charges)))
 505                (3 (:user (:magic-user :elf))
 506                   `(:staff ,(choose 19 'air
 507                                     19 'earth
 508                                     19 'fire
 509                                     19 'water
 510                                     6 'air-and-water
 511                                     6 'earth-and-fire
 512                                     2 'elemental-power)
 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))
 533                   `(:rod inertia))
 534                (1 nil `(:rod parrying))
 535                (1 nil `(:rod victory))
 536                (3 (:user (:dwarf :halfling :elf :fighter
 537                           :paladin :thief :mystic))
 538                   `(:rod weaponry))
 539                (1 nil
 540                   `(:rod wyrm :colour ,(choose 5 'gold
 541                                                3 'blue
 542                                                2 'black)))))
 543            (ring (&optional (recursivep nil))
 544              (pick-matching (form)
 545                (2 (:cursed nil) `(:ring animal-control))
 546                ((if recursivep 0 6)
 547                 (:cursed t)
 548                 (setf form :any)
 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
 553                                                  19 'earth-adaptation
 554                                                  19 'fire-adaptation
 555                                                  19 'water-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))
 561                   `(:ring holiness))
 562                (1 (:cursed nil) `(:ring human-control))
 563                (5 (:cursed nil) `(:ring invisibility))
 564                (3 (:cursed nil) `(:ring life-protection :charges ,(d 6)))
 565                (3 (:cursed nil
 566                    :user (:cleric :druid :magic-user :elf :paladin))
 567                   `(:ring memory))
 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
 571                                                                     3 2
 572                                                                     2 3
 573                                                                     1 4)))
 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))
 580                (2 (:cursed nil)
 581                   (let* ((caster (spell-caster-type))
 582                          (spells (loop repeat (d 6)
 583                                        collect (random-spell caster))))
 584                     `(:ring spell-storing
 585                       :caster ,caster
 586                       :spells ,(remove-duplicates (sort spells
 587                                                         #'string<)))))
 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
 597                                                                  3 2
 598                                                                  2 3
 599                                                                  1 4)))
 600                (2 (:cursed nil) `(:ring x-ray-vision))))
 601            (misc-item ()
 602              (pick-matching (form)
 603                (2 (:cursed nil)
 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
 626                                                           'giant-bat
 627                                                           'black-bear
 628                                                           'grizzly-bear
 629                                                           'boar
 630                                                           'mountain-lion
 631                                                           'panther
 632                                                           'giant-ferret
 633                                                           'gecko
 634                                                           'draco
 635                                                           'racer-snake
 636                                                           'wolf)))
 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))
 642                (2 (:cursed t)
 643                   `(:helm ,(choose-uniformly 'lawful-alignment
 644                                              'neutral-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))
 668                   `(:quill copying))
 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))
 674                (2 (:cursed nil)
 675                   `(:talisman ,(choose-uniformly 'air-travel
 676                                                  'earth-travel
 677                                                  'fire-travel
 678                                                  'water-travel
 679                                                  'elemental-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))
 692            (armour-size ()
 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))
 703                                       (10 `(charm))
 704                                       (15 `(cure-wounds))
 705                                       (10 `(electricity))
 706                                       (5 `(energy-drain))
 707                                       (3 `(ethereality))
 708                                       (10 `(fly))
 709                                       (6 `(gaseous-form))
 710                                       (9 `(haste))
 711                                       (10 `(invisibility))
 712                                       (8 `(reflection))
 713                                       (7 `(remove-curse :charges ,(d 3))))))
 714                     (cursedp (if (and power (eq (car power) 'remove-curse))
 715                                  nil
 716                                  (cursedp 8))))
 717                `(:bonus ,bonus
 718                  ,@(and power (cons :power power))
 719                  :size ,(armour-size)
 720                  ,@(and cursedp `(:cursed t)))))
 721            (armour ()
 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))))))
 750            (opponent ()
 751              (choose 6 'bugs
 752                      3 'constructs
 753                      6 'dragonkind
 754                      9 'enchanted-monsters
 755                      12 'giantkind
 756                      12 'lycanthropes
 757                      4 'planar-monsters
 758                      6 'regenerating-monsters
 759                      9 'reptiles-and-dinosaurs
 760                      3 'spell-immune-monsters
 761                      6 'spellcasters
 762                      12 'undead
 763                      6 'water-breathing-monsters
 764                      6 'weapon-using-monsters))
 765            (weapon-talent (&key missilep)
 766              (pick (5 `(breathing))
 767                    (7 `(charming))
 768                    (4 `(deceiving))
 769                    ((if missilep 0 7) `(defending))
 770                    (2 `(deflecting))
 771                    (2 `(draining :charges ,(+ 4 (d 4))))
 772                    (5 `(extinguishing))
 773                    (6 `(finding))
 774                    (5 `(flaming))
 775                    (3 `(flying))
 776                    (8 `(healing))
 777                    (5 `(hiding))
 778                    (6 `(holding))
 779                    (8 `(lightning))
 780                    (6 `(silencing))
 781                    (2 `(slicing))
 782                    (4 `(slowing))
 783                    (4 `(speeding))
 784                    (5 `(translating))
 785                    (5 `(watching))
 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))))))
 803            (missile ()
 804              (multiple-value-bind
 805                  (item class)
 806                  (pick-matching (form)
 807                    (37 (:user (:thief :fighter :paladin :mystic
 808                               :dwarf :elf :halfling))
 809                        (values :arrow 'a))
 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))
 833                       (values :sling 'd)))
 834                (ecase class
 835                  ((a) (let* ((bonus (weapon-bonus 'a))
 836                              (cursedp (zerop (random 10)))
 837                              (talent (and (percentp (* 5 (- 7 bonus)))
 838                                           (pick (4 'biting)
 839                                                 (5 'blinking)
 840                                                 (5 'charming)
 841                                                 (7 'climbing)
 842                                                 (10 'curing)
 843                                                 (3 'disarming)
 844                                                 (4 'dispelling)
 845                                                 (7 'flying)
 846                                                 (7 'lightning)
 847                                                 (5 'penetrating)
 848                                                 (4 'refilling)
 849                                                 (6 'screaming)
 850                                                 (5 'seeking)
 851                                                 (4 'sinking)
 852                                                 (2 `(slaying
 853                                                      :opponent ,(opponent)))
 854                                                 (7 'speaking)
 855                                                 (4 'stunning)
 856                                                 (2 'teleporting)
 857                                                 (5 'transporting)
 858                                                 (4 'wounding))))
 859                              (number (ecase bonus
 860                                        ((1) (d 10 2))
 861                                        ((2) (d 8 2))
 862                                        ((3) (d 6 2))
 863                                        ((4) (d 4 2))
 864                                        ((5) (+ (d 4) 1)))))
 865                         `(,item :bonus ,bonus
 866                           ,@(and talent `(:talent ,talent))
 867                           :number ,number
 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))
 873                                       ((2 3 4) nil)
 874                                       ((5 6 7) 1.5)
 875                                       ((8 9) 2))))
 876                         `(,item :bonus ,bonus ,@modifier
 877                           ,@(and range `(:range ,range))
 878                           ,@(and cursedp `(:cursed t))))))))
 879            (weapon-intelligence ()
 880              (multiple-value-bind
 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)))
 889                (and int
 890                     (let ((powers nil)
 891                           (healing nil)
 892                           (damage nil)
 893                           (checklist nil))
 894                       (macrolet ((power-check (&rest forms)
 895                                    `(pick ,@(loop for (tag n . form) in forms
 896                                                   if tag
 897                                                   collect
 898                                                   `((if (member ',tag
 899                                                                 checklist)
 900                                                         0
 901                                                         ,n)
 902                                                     (push ',tag checklist)
 903                                                     ,@(or form
 904                                                           `((push ',tag
 905                                                              powers))))
 906                                                   else
 907                                                   collect `(,n ,@form)))))
 908                         (labels ((primary-power ()
 909                                    (power-check
 910                                     (detect-evil 10)
 911                                     (detect-gems 5)
 912                                     (detect-magic 10)
 913                                     (detect-metal 10)
 914                                     (detect-shifting-walls-and-rooms 15)
 915                                     (detect-sloping-passages 15)
 916                                     (find-secret-doors 10)
 917                                     (find-traps 10)
 918                                     (see-invisible 10)
 919                                     (:one-extra 4
 920                                       (extraordinary-power))
 921                                     (:two-primary 1
 922                                       (primary-power)
 923                                       (primary-power))))
 924                                  (extraordinary-power ()
 925                                    (power-check
 926                                     (clairaudience 10)
 927                                     (clairvoyance 10)
 928                                     (esp 10)
 929                                     (nil 5
 930                                       (setf damage (if damage
 931                                                        (1+ damage)
 932                                                        5)))
 933                                     (flying 5)
 934                                     (nil 5
 935                                       (setf healing (+ (or healing 0) 6)))
 936                                     (illusion 9)
 937                                     (levitation 5)
 938                                     (telekinesis 10)
 939                                     (telepathy 10)
 940                                     (teleportation 9)
 941                                     (x-ray-vision 9)
 942                                     (:two-three-extra 2
 943                                       (extraordinary-power)
 944                                       (extraordinary-power))
 945                                     (:two-three-extra 1
 946                                       (extraordinary-power)
 947                                       (extraordinary-power)
 948                                       (extraordinary-power)))))
 949                           (dotimes (i prim) (primary-power))
 950                           (dotimes (i extra) (extraordinary-power))))
 951                       (when damage
 952                         (push `(extra-damage ,damage) powers))
 953                       (when healing
 954                         (push `(healing ,healing) powers))
 955                       `(:intelligence ,int
 956                         :ego ,(d 12)
 957                         :languages ,langs
 958                         ,@(and read-magic-p `(:read-magic t))
 959                         :powers ,powers)))))
 960            (sword ()
 961              (multiple-value-bind
 962                  (type class)
 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
 976                    ,@modifier
 977                    ,@intel
 978                    ,@(and cursedp `(:cursed t))))))
 979            (weapon ()
 980              (multiple-value-bind
 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
 986                               :elf :halfling))
 987                       (values :hand-axe (choose 3 nil 1 t) nil 'b))
 988                    (3 (:user (:fighter :paladin :mystic :dwarf :cleric
 989                               :elf :halfling))
 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
1011                               :elf :halfling))
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
1019                               :elf :halfling))
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
1029                                :elf :halfling))
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))
1040                       (intel (and intelpc
1041                                   (percentp intelpc)
1042                                   (weapon-intelligence))))
1043                  `(,type
1044                    ,@(and returnsp `(:returning t))
1045                    :bonus ,bonus
1046                    ,@modifier
1047                    ,@intel
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)))
1055       (10 (:type :armour
1056            :user (:cleric :druid :fighter :paladin
1057                   :thief :dwarf :elf :halfling))
1058           (armour))
1059       (11 (:type :missile) (list (missile)))
1060       (9 (:type :sword
1061           :user (:fighter :paladin :mystic :thief :dwarf :elf :halfling))
1062          (list (sword)))
1063       (8 (:type :weapon) (list (weapon))))))
1064
1065 (defun treasure-type (type-code)
1066   (labels ((common-fur-type ()
1067              (choose-uniformly 'beaver
1068                                'fox
1069                                'marten
1070                                'seal))
1071            (rare-fur-type ()
1072              (choose-uniformly 'ermine
1073                                'mink
1074                                'sable))
1075            (special (n)
1076              (cons
1077               :special
1078               (loop repeat n
1079                     collect
1080                     (pick (10 `(:kind book
1081                                 :value ,(* 10 (d 100))
1082                                 :encumbrance ,(d 100)))
1083                           (2 `(:kind pelt
1084                                :animal ,(common-fur-type)
1085                                :value ,(d 4)
1086                                :encumbrance ,(* 10 (d 6))))
1087                           (5 `(:kind cape
1088                                :animal ,(common-fur-type)
1089                                :value ,(* 100 (d 6))
1090                                :encumbrance ,(* 10 (+ 4 (d 8)))))
1091                           (3 `(:kind coat
1092                                :animal ,(common-fur-type)
1093                                :value ,(* 100 (d 4 3))
1094                                :encumbrance ,(* 10 (+ 8 (d 6 2)))))
1095                           (2 `(:kind pelt
1096                                :animal ,(rare-fur-type)
1097                                :value ,(d 6 2)
1098                                :encumbrance ,(* 10 (d 6))))
1099                           (5 `(:kind cape
1100                                :animal ,(rare-fur-type)
1101                                :value ,(* 100 (d 6 4))
1102                                :encumbrance ,(* 10 (+ 4 (d 8)))))
1103                           (3 `(:kind coat
1104                                :animal ,(rare-fur-type)
1105                                :value ,(* 1000 (d 4))
1106                                :encumbrance ,(* 10 (+ 8 (d 6 2)))))
1107                           (5 `(:kind incense
1108                                :value ,(d 6 5)
1109                                :encumbrance 1
1110                                :quantity ,(d 4 2)))
1111                           (5 `(:kind perfume
1112                                :value ,(* 10 (+ 5 (d 10)))
1113                                :encumbrance 1
1114                                :quantity ,(d 3 2)))
1115                           (5 (let ((w (d 6)) (h (d 2)))
1116                                `(:kind ,(choose-uniformly 'rug
1117                                                           'tapestry)
1118                                  :value ,(* w h (d 10 2))
1119                                  :encumbrance ,(* 100 w h (d 6))
1120                                  :size (* ,w ,h))))
1121                           (10 (let ((w (d 8)) (h (d 2)))
1122                                 `(:kind silk
1123                                   :value ,(* w h (d 8))
1124                                   :encumbrance ,(* 10 w h (d 6))
1125                                   :size (* ,w ,h))))
1126                           (10 `(:kind animal-skin
1127                                 :value ,(d 10)
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)))
1133                                `(:kind spice
1134                                  :value ,(* enc (d 4 4))
1135                                  :encumbrance ,enc)))
1136                           (5 `(:kind statuette
1137                                :value ,(* 100 (d 10))
1138                                :encumbrance ,(d 100)))
1139                           (5 `(:wine
1140                                :value ,(d 6)
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
1146                                                  'quartz
1147                                                  'turquoise)))
1148                    ((if (<= min-value 50) 7 0)
1149                     (values 50 (choose-uniformly 'crystal
1150                                                  'jasper
1151                                                  'onyx)))
1152                    ((if (<= min-value 100) 15 0)
1153                     (values 100 (choose-uniformly 'amber
1154                                                   'amethyst
1155                                                   'coral
1156                                                   'garnet
1157                                                   'jade)))
1158                    ((if (<= min-value 500) 21 0)
1159                     (values 500 (choose-uniformly 'aquamarine
1160                                                   'pearl
1161                                                   'topaz)))
1162                    ((if (<= min-value 1000) 25 0)
1163                     (values 1000 (choose-uniformly 'carbuncle
1164                                                    'opal)))
1165                    ((if (<= min-value 5000) 19 0)
1166                     (values 5000 (choose-uniformly 'emerald
1167                                                    'ruby
1168                                                    'sapphire)))
1169                    ((if (<= min-value 10000) 7 0)
1170                     (values 10000 'diamond 'jacinth))
1171                    ((if (<= min-value 1000) 1 0)
1172                     (values (* 1000 (d 100))
1173                             'tristal))
1174                    ((if (and (not recursivep)
1175                              (<= min-value 2000)) 2 0)
1176                     (multiple-value-bind
1177                         (value kind)
1178                         (gem-type :min-value (max 1000
1179                                                   (ceiling min-value 2))
1180                                   :recursivep t)
1181                       (values (* 2 value)
1182                               (intern (format nil "STAR-~A"
1183                                               (string kind))))))))
1184            (gems (n)
1185              (cons
1186               :gems
1187               (loop while (plusp n)
1188                     for i = (min n (d 5))
1189                     do (decf n i)
1190                     collect
1191                     (let ((mods (choose 4 :size 4 :qual 2 :both))
1192                           (mod-list nil))
1193                       (multiple-value-bind
1194                           (value kind)
1195                           (gem-type)
1196                         (when (or (eq mods :size)
1197                                   (eq mods :both))
1198                           (multiple-value-bind
1199                               (mod mult)
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)))
1206                             (setf mod-list
1207                                   (append `(:size ,mod) mod-list))
1208                             (setf value (* value mult))))
1209                         (when (or (eq mods :qual)
1210                                   (eq mods :both))
1211                           (multiple-value-bind
1212                               (mod mult)
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)))
1219                             (setf mod-list
1220                                   (append `(:quality ,mod) mod-list))
1221                             (setf value (* value mult))))
1222                       `(:kind ,kind
1223                         :value ,(max 1 (round value))
1224                         ,@mod-list
1225                         ,@(and (> i 1) `(:quantity ,i))))))))
1226            (jewellery (n)
1227              (cons
1228               :jewellery
1229               (loop while (plusp n)
1230                     for i = (min n (d 5))
1231                     do (decf n i)
1232                     collect
1233                     (multiple-value-bind
1234                         (value enc class)
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
1254                                                            'beads
1255                                                            'bracelet
1256                                                            'brooch
1257                                                            'buckle
1258                                                            'cameo
1259                                                            'chain
1260                                                            'clasp
1261                                                            'locket
1262                                                            'pin))
1263                                     ((b) (choose-uniformly 'armband
1264                                                            'belt
1265                                                            'collar
1266                                                            'earring
1267                                                            'four-leaf-clover
1268                                                            'heart
1269                                                            'leaf
1270                                                            'necklace
1271                                                            'pendant
1272                                                            'rabbit-foot))
1273                                     ((c) (choose-uniformly 'amulet
1274                                                            'crown
1275                                                            'diadem
1276                                                            'medallion
1277                                                            'orb
1278                                                            'ring
1279                                                            'scarab
1280                                                            'sceptre
1281                                                            'talisman
1282                                                            'tiara)))))
1283                         `(:kind ,kind
1284                           :value ,value
1285                           :encumbrance ,enc
1286                           ,@(and (> i 1) `(:quantity ,i))))))))
1287            (magic (&rest forms)
1288              (cons :magic
1289                    (loop with list = nil
1290                          for (form n) on forms by #'cddr do
1291                          (loop repeat n do
1292                                (dolist (item (magic-item (list :type form)))
1293                                  (push item list)))
1294                          finally (return list)))))
1295     (ecase type-code
1296
1297       ;; treasure in lair
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)))
1315                 (and (percentp 10)
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)))))
1389
1390       ;; treasure carried
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))))
1415
1416       ;; unguarded treasures
1417       ((unguarded-1)
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)))))))
1452
1453 (defconstant combine-treasures
1454   '((:coins (t . +))
1455     (t . append)))
1456
1457 (defun combine2 (spec a b)
1458   (labels ((comb (tag x y)
1459              (dolist (pair spec)
1460                (let ((label (car pair)))
1461                  (when (or (eq label t)
1462                            (eq label tag))
1463                    (return-from comb
1464                      (let ((method (cdr pair)))
1465                        (etypecase method
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)))
1471     (let ((list nil))
1472       (dolist (pair a)
1473         (let* ((tag (car pair))
1474                (match (assoc tag b)))
1475           (push (if (null match)
1476                     pair
1477                     (cons tag
1478                           (comb tag (cdr pair) (cdr match))))
1479                 list)))
1480       (dolist (pair b)
1481         (let* ((tag (car pair))
1482                (match (assoc tag a)))
1483           (unless match
1484             (push pair list))))
1485       (nreverse list))))
1486
1487 (defun combine (spec &rest lists)
1488   (reduce (lambda (x y) (combine2 spec x y)) lists))
1489
1490 (defun treasure (types)
1491   (apply #'combine
1492          combine-treasures
1493          (loop for type in types
1494                collect (treasure-type type))))
1495
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))
1500                       #'string<)))