mdw@git.distorted.org.uk Git - 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 (defconstant cleric-spells
 187   #((cure-light-wounds detect-evil detect-magic light protection-from-evil
 188      purify-food-and-water remove-fear resist-cold)
 189     (bless find-traps hold-person resist-fire silence-15-ft-radius
 190      slow-poison snake-charm speak-with-animal)
 191     (continual-light cure-blindness cure-disease growth-of-animals
 192      locate-object remove-curse speak-with-the-dead striking)
 193     (animate-dead create-water cure-serious-wounds dispel-magic
 194      neutralize-poison protection-from-evil-10-ft-radius speak-with-plants
 195      sticks-to-snakes)
 196     (commune create-food cure-critical-wounds dispel-evil insect-plague quest
 197      raise-dead truesight)
 198     (aerial-servant animate-objects barrier create-normal-animals cureall
 199      find-the-path speak-with-monsters word-of-recall)
 200     (earthquake holy-word raise-dead-fully restore survival travel wish
 201      wizardry)))
 202
 203 (defconstant druid-only-spells
 204   #((detect-danger faerie-fire locate predict-weather)
 205     (heat-metal obscure produce-fire warp-wood)
 206     (call-lightning hold-animal protection-from-poison water-breathing)
 207     (control-temperature-10-ft-radius plant-door protection-from-lightning
 208      summon-animals)
 209     (anti-plant-shell control-winds dissolve pass-plant)
 210     (anti-animal-shell summon-weather transport-through-plants turn-wood)
 211     (creeping-doom metal-to-wood summon-elemental weather-control)))
 212
 213 (defconstant druid-spells
 214   (make-array 7 :initial-contents (loop for cs across cleric-spells
 215                                         for ds across druid-only-spells
 216                                         collect (append cs ds))))
 217
 218 (defconstant magic-user-spells
 219   #((analyse charm-person detect-magic floating-disc hold-portal light
 220      magic-missile protection-from-evil read-languages read-magic shield
 221      sleep ventriloquism)
 222     (continual-light detect-evil detect-invisible entangle esp invisibility
 223      knock levitate locate-object mirror-image phantasmal-force web
 224      wizard-lock)
 225     (clairvoyance create-air dispel-magic fire-ball fly haste hold-person
 226      infravision invisibility-10-ft-radius lightning-bolt
 227      protection-from-evil-10-ft-radius protection-from-normal-missiles
 228      water-breathing)
 229     (charm-monster clothform confusion dimension-door growth-of-plants
 230      hallucinatory-terrain ice-storm/wall massmorph polymorph-others
 231      polymorph-self remove-curse wall-of-fire wizard-eye)
 232     (animate-dead cloudkill conjure-elemental contact-outer-plane dissolve
 233      feeblemind hold-monster magic-jar pass-wall telekinesis teleport
 234      wall-of-stone woodform)
 235     (anti-magic-shell death-spell disintegrate geas invisible-stalker
 236      lower-water move-earth projected-image reincarnation stone-to-flesh
 237      stoneform wall-of-iron weather-control)
 238     (charm-plant create-normal-monsters delayed-blast-fire-ball ironform lore
 239      magic-door mass-invisibility power-word-stun reverse-gravity statue
 240      summon-object sword teleport-any-object)
 241     (clone create-magical-monsters dance explosive-cloud force-field
 242      mass-charm mind-barrier permanence polymorph-any-object power-word-blind
 243      steelform symbol travel)
 244     (contingency create-any-monster gate heal immunity maze meteor-swarm
 245      power-word-kill prismatic-wall shapechange survival timestop wish)))
 246
 247 (defun spell-caster-type (&optional (form :any))
 248   (pick-matching (form)
 249     (5 (:user (:cleric :druid :paladin)) :cleric)
 250     (1 (:user :druid) :druid)
 251     (14 (:user (:magic-user :elf :thief)) :magic-user)))
 252
 253 (defun random-spell (&optional (caster (spell-caster-type))
 254                                (level (ecase caster
 255                                         ((:magic-user) (choose 28 1
 256                                                                21 2
 257                                                                15 3
 258                                                                11 4
 259                                                                 9 5
 260                                                                 7 6
 261                                                                 5 7
 262                                                                 3 8
 263                                                                 1 9))
 264                                         ((:cleric :druid) (choose 34 1
 265                                                                   24 2
 266                                                                   18 3
 267                                                                   12 4
 268                                                                    7 5
 269                                                                    4 6
 270                                                                    1 7)))))
 271   (let ((list (aref (ecase caster
 272                       ((:magic-user) magic-user-spells)
 273                       ((:cleric) cleric-spells)
 274                       ((:druid) druid-only-spells))
 275                     level)))
 276     (values (elt list (random (length list)))
 277             caster
 278             level)))
 279
 280 (let ((magic (list :magic)))
 281   (defun assertion-match-p (form assertions)
 282     (cond ((eq form :any) t)
 283           ((eq form :none) nil)
 284           ((atom form) (if (atom assertions)
 285                            (eql form assertions)
 286                            (member form assertions)))
 287           (t (case (car form)
 288                ((and) (every (lambda (f)
 289                                (assertion-match-p f assertions))
 290                              (cdr form)))
 291                ((or) (some (lambda (f)
 292                              (assertion-match-p f assertions))
 293                            (cdr form)))
 294                ((not) (not (assertion-match-p (cadr form) assertions)))
 295                (t (let ((sub (getf assertions (car form) magic)))
 296                     (if (eq sub magic)
 297                         t
 298                         (assertion-match-p (cadr form) sub)))))))))
 299
 300 (defun choose-distinct-items (n seq)
 301   (let* ((copy (subseq (coerce seq 'vector) 0))
 302          (len (length copy))
 303          (list nil))
 304     (dotimes (i n (sort list #'string<))
 305       (let ((j (random len)))
 306         (push (aref copy j) list)
 307         (decf len)
 308         (setf (aref copy j) (aref copy len))))))
 309
 310 (defmacro pick-matching ((form &key) &body clauses)
 311   (let ((formtemp (gensym "FORM")))
 312     `(let ((,formtemp ,form))
 313        (pick ,@(loop for (prob assertion . code) in clauses
 314                      collect `((if (assertion-match-p ,formtemp ',assertion)
 315                                    ,prob
 316                                    0)
 317                                ,@code))))))
 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                                           (choose 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                                                   7 'speaking
 854                                                   4 'stunning
 855                                                   2 'teleporting
 856                                                   5 'transporting
 857                                                   4 'wounding)))
 858                              (number (ecase bonus
 859                                        ((1) (d 10 2))
 860                                        ((2) (d 8 2))
 861                                        ((3) (d 6 2))
 862                                        ((4) (d 4 2))
 863                                        ((5) (+ (d 4) 1)))))
 864                         `(,item :bonus ,bonus
 865                           ,@(and talent `(:talent ,talent))
 866                           :number ,number
 867                           ,@(and cursedp `(:cursed t)))))
 868                  ((d) (let* ((bonus (weapon-bonus 'd))
 869                              (cursedp (cursedp 10))
 870                              (modifier (weapon-modifier bonus :missilep t))
 871                              (range (ecase (+ bonus (d 4))
 872                                       ((2 3 4) nil)
 873                                       ((5 6 7) 1.5)
 874                                       ((8 9) 2))))
 875                         `(,item :bonus ,bonus ,@modifier
 876                           ,@(and range `(:range ,range))
 877                           ,@(and cursedp `(:cursed t))))))))
 878            (weapon-intelligence ()
 879              (multiple-value-bind
 880                  (int langs prim read-magic-p extra)
 881                  (pick (79 (values nil 0 0 nil 0))
 882                        (6 (values 7 0 1 nil 0))
 883                        (5 (values 8 0 2 nil 0))
 884                        (4 (values 9 0 3 nil 0))
 885                        (3 (values 10 (d 3) 3 nil 0))
 886                        (2 (values 11 (d 6) 3 t 0))
 887                        (1 (values 12 (d 4 2) 3 t 1)))
 888                (and int
 889                     (let ((powers nil)
 890                           (healing nil)
 891                           (damage nil)
 892                           (checklist nil))
 893                       (macrolet ((power-check (&rest forms)
 894                                    `(pick ,@(loop for (tag n . form) in forms
 895                                                   if tag
 896                                                   collect
 897                                                   `((if (member ',tag
 898                                                                 checklist)
 899                                                         0
 900                                                         ,n)
 901                                                     (push ',tag checklist)
 902                                                     ,@(or form
 903                                                           `((push ',tag
 904                                                              powers))))
 905                                                   else
 906                                                   collect `(,n ,@form)))))
 907                         (labels ((primary-power ()
 908                                    (power-check
 909                                     (detect-evil 10)
 910                                     (detect-gems 5)
 911                                     (detect-magic 10)
 912                                     (detect-metal 10)
 913                                     (detect-shifting-walls-and-rooms 15)
 914                                     (detect-sloping-passages 15)
 915                                     (find-secret-doors 10)
 916                                     (find-traps 10)
 917                                     (see-invisible 10)
 918                                     (:one-extra 4
 919                                       (extraordinary-power))
 920                                     (:two-primary 1
 921                                       (primary-power)
 922                                       (primary-power))))
 923                                  (extraordinary-power ()
 924                                    (power-check
 925                                     (clairaudience 10)
 926                                     (clairvoyance 10)
 927                                     (esp 10)
 928                                     (nil 5
 929                                       (setf damage (if damage
 930                                                        (1+ damage)
 931                                                        5)))
 932                                     (flying 5)
 933                                     (nil 5
 934                                       (setf healing (+ (or healing 0) 6)))
 935                                     (illusion 9)
 936                                     (levitation 5)
 937                                     (telekinesis 10)
 938                                     (telepathy 10)
 939                                     (teleportation 9)
 940                                     (x-ray-vision 9)
 941                                     (:two-three-extra 2
 942                                       (extraordinary-power)
 943                                       (extraordinary-power))
 944                                     (:two-three-extra 1
 945                                       (extraordinary-power)
 946                                       (extraordinary-power)
 947                                       (extraordinary-power)))))
 948                           (dotimes (i prim) (primary-power))
 949                           (dotimes (i extra) (extraordinary-power))))
 950                       (when damage
 951                         (push `(extra-damage ,damage) powers))
 952                       (when healing
 953                         (push `(healing ,healing) powers))
 954                       `(:intelligence ,int
 955                         :ego ,(d 12)
 956                         :languages ,langs
 957                         ,@(and read-magic-p `(:read-magic t))
 958                         :powers ,powers)))))
 959            (sword ()
 960              (multiple-value-bind
 961                  (type class)
 962                  (pick-matching (form)
 963                    (65 nil (values :normal-sword 'c))
 964                    (19 nil (values :short-sword 'c))
 965                    (8 (:user (:fighter :paladin :dwarf :mystic :elf))
 966                       (values :two-handed-sword 'd))
 967                    (8 (:user (:fighter :paladin :dwarf
 968                               :mystic :elf :halfling))
 969                       (values :bastard-sword 'd)))
 970                (let* ((bonus (weapon-bonus class))
 971                       (cursedp (zerop (random 10)))
 972                       (modifier (sword-modifier bonus))
 973                       (intel (weapon-intelligence)))
 974                  `(,type :bonus ,bonus
 975                    ,@modifier
 976                    ,@intel
 977                    ,@(and cursedp `(:cursed t))))))
 978            (weapon ()
 979              (multiple-value-bind
 980                  (type returnsp intelpc class)
 981                  (pick-matching (form)
 982                    (7 (:user (:fighter :paladin :mystic :dwarf :elf))
 983                       (values :battle-axe nil 30 'd))
 984                    (8 (:user (:fighter :paladin :mystic :dwarf :thief
 985                               :elf :halfling))
 986                       (values :hand-axe (choose 3 nil 1 t) nil 'b))
 987                    (3 (:user (:fighter :paladin :mystic :dwarf :cleric
 988                               :elf :halfling))
 989                       (values :blackjack nil nil 'c))
 990                    (3 (:user (:fighter :paladin :mystic :dwarf :cleric
 991                               :thief :elf :halfling))
 992                       (values :bola (choose 2 nil 1 t) nil 'b))
 993                    (5 (:user (:fighter :paladin :mystic :dwarf
 994                               :thief :cleric :druid :elf :halfling))
 995                       (values :club nil nil 'c))
 996                    (14 (:user (:fighter :paladin :mystic :dwarf :magic-user
 997                                :thief :elf :halfling))
 998                        (values :dagger (choose 11 nil 3 t) 50 'b))
 999                    (4 (:user (:fighter :paladin :mystic :dwarf :cleric
1000                               :elf :halfling :thief))
1001                       (values :one-handed-flail nil nil 'c))
1002                    (2 (:user (:fighter :paladin :mystic :dwarf :cleric :elf))
1003                       (values :two-handed-flail nil nil 'd))
1004                    (3 (:user (:fighter :paladin :mystic :dwarf :elf))
1005                       (values :halberd nil 20 'd))
1006                    (8 (:user (:fighter :paladin :mystic :dwarf :cleric
1007                               :druid :elf :halfling :thief))
1008                       (values :war-hammer nil 30 'c))
1009                    (4 (:user (:fighter :paladin :mystic :dwarf :thief
1010                               :elf :halfling))
1011                       (values :javelin (choose 3 nil 1 t) nil 'b))
1012                    (4 (:user (:fighter :paladin :mystic :dwarf :elf))
1013                       (values :lance nil nil 'd))
1014                    (7 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
1015                               :elf :halfling :druid))
1016                       (values :mace nil 35 'c))
1017                    (5 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
1018                               :elf :halfling))
1019                       (values :morning-star nil nil 'c))
1020                    (3 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
1021                               :druid :elf :halfling))
1022                       (values :net (choose 2 nil 1 t) nil 'b))
1023                    (3 (:user (:fighter :paladin :mystic :dwarf :elf))
1024                       (values :pike nil 20 'd))
1025                    (2 (:user (:fighter :paladin :mystic :dwarf :elf))
1026                       (values :pole-axe nil 20 'd))
1027                    (12 (:user (:fighter :paladin :mystic :dwarf :thief
1028                                :elf :halfling))
1029                        (values :spear (choose 3 nil 1 t) nil 'b))
1030                    (4 (:user (:fighter :paladin :mystic :dwarf :thief :cleric
1031                               :druid :elf :halfling :magic-user))
1032                       (values :staff nil 20 'd))
1033                    (3 (:user (:fighter :paladin :mystic :dwarf :thief :cleric
1034                               :druid :elf :halfling))
1035                       (values :whip nil nil 'c)))
1036                (let* ((bonus (weapon-bonus class))
1037                       (cursedp (cursedp 10))
1038                       (modifier (sword-modifier bonus))
1039                       (intel (and intelpc
1040                                   (percentp intelpc)
1041                                   (weapon-intelligence))))
1042                  `(,type
1043                    ,@(and returnsp `(:returning t))
1044                    :bonus ,bonus
1045                    ,@modifier
1046                    ,@intel
1047                    ,@(and cursedp `(:cursed t)))))))
1048     (pick-matching (form)
1049       (25 (:type :potion) (list (potion)))
1050       (12 (:type :scroll) (list (scroll)))
1051       (9 (:type :wandlike :cursed nil) (list (wandlike)))
1052       (6 (:type :ring) (list (ring)))
1053       (10 (:type :misc) (list (misc-item)))
1054       (10 (:type :armour
1055            :user (:cleric :druid :fighter :paladin
1056                   :thief :dwarf :elf :halfling))
1057           (armour))
1058       (11 (:type :missile) (list (missile)))
1059       (9 (:type :sword
1060           :user (:fighter :paladin :mystic :thief :dwarf :elf :halfling))
1061          (list (sword)))
1062       (8 (:type :weapon) (list (weapon))))))
1063
1064 (defun treasure-type (type-code)
1065   (labels ((common-fur-type ()
1066              (choose-uniformly 'beaver
1067                                'fox
1068                                'marten
1069                                'seal))
1070            (rare-fur-type ()
1071              (choose-uniformly 'ermine
1072                                'mink
1073                                'sable))
1074            (special (n)
1075              (cons
1076               :special
1077               (loop repeat n
1078                     collect
1079                     (pick (10 `(:kind book
1080                                 :value ,(* 10 (d 100))
1081                                 :encumbrance ,(d 100)))
1082                           (2 `(:kind pelt
1083                                :animal ,(common-fur-type)
1084                                :value ,(d 4)
1085                                :encumbrance ,(* 10 (d 6))))
1086                           (5 `(:kind cape
1087                                :animal ,(common-fur-type)
1088                                :value ,(* 100 (d 6))
1089                                :encumbrance ,(* 10 (+ 4 (d 8)))))
1090                           (3 `(:kind coat
1091                                :animal ,(common-fur-type)
1092                                :value ,(* 100 (d 4 3))
1093                                :encumbrance ,(* 10 (+ 8 (d 6 2)))))
1094                           (2 `(:kind pelt
1095                                :animal ,(rare-fur-type)
1096                                :value ,(d 6 2)
1097                                :encumbrance ,(* 10 (d 6))))
1098                           (5 `(:kind cape
1099                                :animal ,(rare-fur-type)
1100                                :value ,(* 100 (d 6 4))
1101                                :encumbrance ,(* 10 (+ 4 (d 8)))))
1102                           (3 `(:kind coat
1103                                :animal ,(rare-fur-type)
1104                                :value ,(* 1000 (d 4))
1105                                :encumbrance ,(* 10 (+ 8 (d 6 2)))))
1106                           (5 `(:kind incense
1107                                :value ,(d 6 5)
1108                                :encumbrance 1
1109                                :quantity ,(d 4 2)))
1110                           (5 `(:kind perfume
1111                                :value ,(* 10 (+ 5 (d 10)))
1112                                :encumbrance 1
1113                                :quantity ,(d 3 2)))
1114                           (5 (let ((w (d 6)) (h (d 2)))
1115                                `(:kind ,(choose-uniformly 'rug
1116                                                           'tapestry)
1117                                  :value ,(* w h (d 10 2))
1118                                  :encumbrance ,(* 100 w h (d 6))
1119                                  :size (* ,w ,h))))
1120                           (10 (let ((w (d 8)) (h (d 2)))
1121                                 `(:kind silk
1122                                   :value ,(* w h (d 8))
1123                                   :encumbrance ,(* 10 w h (d 6))
1124                                   :size (* ,w ,h))))
1125                           (10 `(:kind animal-skin
1126                                 :value ,(d 10)
1127                                 :encumbrance ,(* 10 (d 4 5))))
1128                           (10 `(:kind monster-skin
1129                                 :value ,(* 100 (d 10))
1130                                 :encumbrance ,(* 50 (d 100))))
1131                           (5 (let ((enc (d 100)))
1132                                `(:kind spice
1133                                  :value ,(* enc (d 4 4))
1134                                  :encumbrance ,enc)))
1135                           (5 `(:kind statuette
1136                                :value ,(* 100 (d 10))
1137                                :encumbrance ,(d 100)))
1138                           (5 `(:wine
1139                                :value ,(d 6)
1140                                :encumbrance ,(* 10 (+ 3 (d 6)))
1141                                :bottles ,(d 12)))))))
1142            (gem-type (&key (min-value 0) recursivep)
1143              (pick ((if (<= min-value 10) 3 0)
1144                     (values 10 (choose-uniformly 'agate
1145                                                  'quartz
1146                                                  'turquoise)))
1147                    ((if (<= min-value 50) 7 0)
1148                     (values 50 (choose-uniformly 'crystal
1149                                                  'jasper
1150                                                  'onyx)))
1151                    ((if (<= min-value 100) 15 0)
1152                     (values 100 (choose-uniformly 'amber
1153                                                   'amethyst
1154                                                   'coral
1155                                                   'garnet
1156                                                   'jade)))
1157                    ((if (<= min-value 500) 21 0)
1158                     (values 500 (choose-uniformly 'aquamarine
1159                                                   'pearl
1160                                                   'topaz)))
1161                    ((if (<= min-value 1000) 25 0)
1162                     (values 1000 (choose-uniformly 'carbuncle
1163                                                    'opal)))
1164                    ((if (<= min-value 5000) 19 0)
1165                     (values 5000 (choose-uniformly 'emerald
1166                                                    'ruby
1167                                                    'sapphire)))
1168                    ((if (<= min-value 10000) 7 0)
1169                     (values 10000 'diamond 'jacinth))
1170                    ((if (<= min-value 1000) 1 0)
1171                     (values (* 1000 (d 100))
1172                             'tristal))
1173                    ((if (and (not recursivep)
1174                              (<= min-value 2000)) 2 0)
1175                     (multiple-value-bind
1176                         (value kind)
1177                         (gem-type :min-value (max 1000
1178                                                   (ceiling min-value 2))
1179                                   :recursivep t)
1180                       (values (* 2 value)
1181                               (intern (format nil "STAR-~A"
1182                                               (string kind))))))))
1183            (gems (n)
1184              (cons
1185               :gems
1186               (loop while (plusp n)
1187                     for i = (min n (d 5))
1188                     do (decf n i)
1189                     collect
1190                     (let ((mods (choose 4 :size 4 :qual 2 :both))
1191                           (mod-list nil))
1192                       (multiple-value-bind
1193                           (value kind)
1194                           (gem-type)
1195                         (when (or (eq mods :size)
1196                                   (eq mods :both))
1197                           (multiple-value-bind
1198                               (mod mult)
1199                               (pick (1 (values 'very-small 1/8))
1200                                     (2 (values 'small 1/4))
1201                                     (2 (values 'fairly-small 1/2))
1202                                     (2 (values 'fairly-large 2))
1203                                     (2 (values 'large 4))
1204                                     (1 (values 'very-small 8)))
1205                             (setf mod-list
1206                                   (append `(:size ,mod) mod-list))
1207                             (setf value (* value mult))))
1208                         (when (or (eq mods :qual)
1209                                   (eq mods :both))
1210                           (multiple-value-bind
1211                               (mod mult)
1212                               (pick (1 (values 'very-poor 1/8))
1213                                     (2 (values 'poor 1/4))
1214                                     (2 (values 'fairly-poor 1/2))
1215                                     (2 (values 'fairly-good 2))
1216                                     (2 (values 'good 4))
1217                                     (1 (values 'very-good 8)))
1218                             (setf mod-list
1219                                   (append `(:quality ,mod) mod-list))
1220                             (setf value (* value mult))))
1221                       `(:kind ,kind
1222                         :value ,(max 1 (round value))
1223                         ,@mod-list
1224                         ,@(and (> i 1) `(:quantity ,i))))))))
1225            (jewellery (n)
1226              (cons
1227               :jewellery
1228               (loop while (plusp n)
1229                     for i = (min n (d 5))
1230                     do (decf n i)
1231                     collect
1232                     (multiple-value-bind
1233                         (value enc class)
1234                         (pick ( 1 (values   100 10 'a))
1235                               ( 2 (values   500 10 'a))
1236                               ( 3 (values  1000 10 'a))
1237                               ( 4 (values  1500 10 'a))
1238                               ( 5 (values  2000 10 'a))
1239                               ( 8 (values  2500 10 'a))
1240                               (10 (values  3000 25 'a))
1241                               (11 (values  4000 25 'b))
1242                               (13 (values  5000 25 'b))
1243                               (11 (values  7500 25 'b))
1244                               ( 9 (values 10000 25 'b))
1245                               ( 7 (values 15000 25 'c))
1246                               ( 5 (values 20000 50 'c))
1247                               ( 4 (values 25000 50 'c))
1248                               ( 3 (values 30000 50 'c))
1249                               ( 2 (values 40000 50 'c))
1250                               ( 1 (values 50000 50 'c)))
1251                       (let ((kind (ecase class
1252                                     ((a) (choose-uniformly 'anklet
1253                                                            'beads
1254                                                            'bracelet
1255                                                            'brooch
1256                                                            'buckle
1257                                                            'cameo
1258                                                            'chain
1259                                                            'clasp
1260                                                            'locket
1261                                                            'pin))
1262                                     ((b) (choose-uniformly 'armband
1263                                                            'belt
1264                                                            'collar
1265                                                            'earring
1266                                                            'four-leaf-clover
1267                                                            'heart
1268                                                            'leaf
1269                                                            'necklace
1270                                                            'pendant
1271                                                            'rabbit-foot))
1272                                     ((c) (choose-uniformly 'amulet
1273                                                            'crown
1274                                                            'diadem
1275                                                            'medallion
1276                                                            'orb
1277                                                            'ring
1278                                                            'scarab
1279                                                            'sceptre
1280                                                            'talisman
1281                                                            'tiara)))))
1282                         `(:kind ,kind
1283                           :value ,value
1284                           :encumbrance ,enc
1285                           ,@(and (> i 1) `(:quantity ,i))))))))
1286            (magic (&rest forms)
1287              (cons :magic
1288                    (loop with list = nil
1289                          for (form n) on forms by #'cddr do
1290                          (loop repeat n do
1291                                (dolist (item (magic-item (list :type form)))
1292                                  (push item list)))
1293                          finally (return list)))))
1294     (ecase type-code
1295
1296       ;; treasure in lair
1297       ((a) (bag (tagged-bag :coins
1298                             (and (percentp 25) `(:cp ,(* 1000 (d 6))))
1299                             (and (percentp 30) `(:sp ,(* 1000 (d 6))))
1300                             (and (percentp 20) `(:ep ,(* 1000 (d 4))))
1301                             (and (percentp 35) `(:gp ,(* 1000 (d 6 2))))
1302                             (and (percentp 25) `(:pp ,(* 1000 (d 2)))))
1303                 (and (percentp 50) (gems (d 6 6)))
1304                 (and (percentp 50) (jewellery (d 6 6)))
1305                 (and (percentp 10) (special (d 2)))
1306                 (and (percentp 30) (magic :any 3))))
1307       ((b) (bag (tagged-bag :coins
1308                             (and (percentp 50) `(:cp ,(* 1000 (d 8))))
1309                             (and (percentp 25) `(:sp ,(* 1000 (d 6))))
1310                             (and (percentp 25) `(:ep ,(* 1000 (d 4))))
1311                             (and (percentp 35) `(:gp ,(* 1000 (d 3)))))
1312                 (and (percentp 25) (gems (d 6)))
1313                 (and (percentp 25) (jewellery (d 6)))
1314                 (and (percentp 10)
1315                      (magic '(or :armour :missile :sword :weapon) 1))))
1316       ((c) (bag (tagged-bag :coins
1317                             (and (percentp 20) `(:cp ,(* 1000 (d 12))))
1318                             (and (percentp 30) `(:sp ,(* 1000 (d 4))))
1319                             (and (percentp 10) `(:ep ,(* 1000 (d 4)))))
1320                 (and (percentp 50) (gems (d 6 6)))
1321                 (and (percentp 50) (jewellery (d 6 6)))
1322                 (and (percentp 5) (special (d 2)))
1323                 (and (percentp 10) (magic :any 2))))
1324       ((d) (bag (tagged-bag :coins
1325                             (and (percentp 10) `(:cp ,(* 1000 (d 8))))
1326                             (and (percentp 15) `(:sp ,(* 1000 (d 12))))
1327                             (and (percentp 60) `(:gp ,(* 1000 (d 6)))))
1328                 (and (percentp 30) (gems (d 8)))
1329                 (and (percentp 30) (jewellery (d 8)))
1330                 (and (percentp 10) (special (d 2)))
1331                 (and (percentp 10) (magic :any 1 :potion 1))))
1332       ((e) (bag (tagged-bag :coins
1333                             (and (percentp 5) `(:cp ,(* 1000 (d 10))))
1334                             (and (percentp 30) `(:sp ,(* 1000 (d 12))))
1335                             (and (percentp 25) `(:ep ,(* 1000 (d 4))))
1336                             (and (percentp 25) `(:gp ,(* 1000 (d 8)))))
1337                 (and (percentp 10) (gems (d 10)))
1338                 (and (percentp 10) (jewellery (d 10)))
1339                 (and (percentp 15) (special (d 2)))
1340                 (and (percentp 25) (magic :any 3 :scroll 1))))
1341       ((f) (bag (tagged-bag :coins
1342                             (and (percentp 30) `(:sp ,(* 1000 (d 10 2))))
1343                             (and (percentp 20) `(:ep ,(* 1000 (d 8))))
1344                             (and (percentp 45) `(:gp ,(* 1000 (d 12))))
1345                             (and (percentp 30) `(:pp ,(* 1000 (d 3)))))
1346                 (and (percentp 20) (gems (d 12 2)))
1347                 (and (percentp 10) (jewellery (d 12)))
1348                 (and (percentp 20) (special (d 3)))
1349                 (and (percentp 30) (magic :potion 1 :scroll 1
1350                                           '(not :armour :missile
1351                                             :sword :weapon) 3))))
1352       ((g) (bag (tagged-bag :coins
1353                             (and (percentp 50) `(:gp ,(* 10000 (d 4))))
1354                             (and (percentp 50) `(:pp ,(* 1000 (d 6)))))
1355                 (and (percentp 25) (gems (d 6 3)))
1356                 (and (percentp 25) (jewellery (d 10)))
1357                 (and (percentp 30) (special (d 3)))
1358                 (and (percentp 35) (magic :any 4 :scroll 1))))
1359       ((h) (bag (tagged-bag :coins
1360                             (and (percentp 25) `(:cp ,(* 1000 (d 8 3))))
1361                             (and (percentp 50) `(:sp ,(* 1000 (d 100))))
1362                             (and (percentp 50) `(:ep ,(* 10000 (d 4))))
1363                             (and (percentp 50) `(:gp ,(* 10000 (d 6))))
1364                             (and (percentp 25) `(:pp ,(* 1000 (d 4 5)))))
1365                 (and (percentp 50) (gems (d 100)))
1366                 (and (percentp 50) (jewellery (* 10 (d 4))))
1367                 (and (percentp 10) (special (d 2)))
1368                 (and (percentp 15) (magic :any 4 :potion 1 :scroll 1))))
1369       ((i) (bag (tagged-bag :coins
1370                             (and (percentp 30) `(:pp ,(* 1000 (d 8)))))
1371                 (and (percentp 50) (gems (d 6 2)))
1372                 (and (percentp 50) (jewellery (d 6 2)))
1373                 (and (percentp 5) (special (d 2)))
1374                 (and (percentp 15) (magic :any 1))))
1375       ((j) (bag (tagged-bag :coins
1376                             (and (percentp 25) `(:cp ,(* 1000 (d 4))))
1377                             (and (percentp 10) `(:sp ,(* 1000 (d 3)))))))
1378       ((k) (bag (tagged-bag :coins
1379                             (and (percentp 30) `(:sp ,(* 1000 (d 6))))
1380                             (and (percentp 10) `(:ep ,(* 1000 (d 2)))))))
1381       ((l) (bag (and (percentp 50) (gems (d 4)))))
1382       ((m) (bag (and (percentp 55) (gems (d 4)))
1383                 (and (percentp 45) (jewellery (d 6 2)))))
1384       ((n) (bag (and (percentp 10) (special (d 2)))
1385                 (and (percentp 40) (magic :potion (d 4 2)))))
1386       ((o) (bag (and (percentp 10) (special (d 3)))
1387                 (and (percentp 50) (magic :scroll (d 4)))))
1388
1389       ;; treasure carried
1390       ((p) (bag (tagged-bag :coins `(:cp ,(d 8 3)))))
1391       ((q) (bag (tagged-bag :coins `(:sp ,(d 6 3)))))
1392       ((r) (bag (tagged-bag :coins `(:ep ,(d 6 2)))))
1393       ((s) (bag (tagged-bag :coins `(:gp ,(d 4 2)))
1394                 (and (percentp 5) (gems 1))))
1395       ((t) (bag (tagged-bag :coins `(:pp ,(d 6 1)))
1396                 (and (percentp 5) (gems 1))))
1397       ((u) (bag (tagged-bag :coins
1398                             (and (percentp 10) `(:cp ,(d 100)))
1399                             (and (percentp 10) `(:sp ,(d 100)))
1400                             (and (percentp 5) `(:gp ,(d 100))))
1401                 (and (percentp 5) (gems (d 2)))
1402                 (and (percentp 5) (gems (d 4)))
1403                 (and (percentp 2) (special 1))
1404                 (and (percentp 2) (magic :any 1))))
1405       ((v) (bag (tagged-bag :coins
1406                             (and (percentp 10) `(:sp ,(d 100)))
1407                             (and (percentp 5) `(:ep ,(d 100)))
1408                             (and (percentp 5) `(:gp ,(d 100)))
1409                             (and (percentp 5) `(:pp ,(d 100))))
1410                 (and (percentp 10) (gems (d 2)))
1411                 (and (percentp 10) (gems (d 4)))
1412                 (and (percentp 5) (special 1))
1413                 (and (percentp 5) (magic :any 1))))
1414
1415       ;; unguarded treasures
1416       ((unguarded-1)
1417        (bag (tagged-bag :coins
1418                         `(:sp ,(* 100 (d 6)))
1419                         (and (percentp 50) `(:gp ,(* 10 (d 6)))))
1420             (and (percentp 5) (gems (d 6)))
1421             (and (percentp 2) (jewellery (d 6)))
1422             (and (percentp 2) (magic :any 1))))
1423       ((unguarded-2 unguarded-3)
1424        (bag (tagged-bag :coins
1425                         `(:sp ,(* 100 (d 12)))
1426                         (and (percentp 50) `(:gp ,(* 100 (d 6)))))
1427             (and (percentp 10) (gems (d 6)))
1428             (and (percentp 5) (jewellery (d 6)))
1429             (and (percentp 8) (magic :any 1))))
1430       ((unguarded-4 unguarded-5)
1431        (bag (tagged-bag :coins
1432                         `(:sp ,(* 1000 (d 6)))
1433                         `(:gp ,(* 200 (d 6))))
1434             (and (percentp 20) (gems (d 8)))
1435             (and (percentp 10) (jewellery (d 8)))
1436             (and (percentp 10) (magic :any 1))))
1437       ((unguarded-6 unguarded-7)
1438        (bag (tagged-bag :coins
1439                         `(:sp ,(* 2000 (d 6)))
1440                         `(:gp ,(* 500 (d 6))))
1441             (and (percentp 30) (gems (d 10)))
1442             (and (percentp 15) (jewellery (d 10)))
1443             (and (percentp 15) (magic :any 1))))
1444       ((unguarded-8 unguarded-9)
1445        (bag (tagged-bag :coins
1446                         `(:sp ,(* 5000 (d 6)))
1447                         `(:gp ,(* 1000 (d 6))))
1448             (and (percentp 40) (gems (d 12)))
1449             (and (percentp 20) (jewellery (d 12)))
1450             (and (percentp 20) (magic :any 1)))))))
1451
1452 (defconstant combine-treasures
1453   '((:coins (t . +))
1454     (t . append)))
1455
1456 (defun combine2 (spec a b)
1457   (labels ((comb (tag x y)
1458              (dolist (pair spec)
1459                (let ((label (car pair)))
1460                  (when (or (eq label t)
1461                            (eq label tag))
1462                    (return-from comb
1463                      (let ((method (cdr pair)))
1464                        (etypecase method
1465                          (list (combine2 method x y))
1466                          ((member +) (list (+ (car x) (car y))))
1467                          ((or symbol function)
1468                           (funcall method x y))))))))
1469              (error "No combiner found for ~S." tag)))
1470     (let ((list nil))
1471       (dolist (pair a)
1472         (let* ((tag (car pair))
1473                (match (assoc tag b)))
1474           (push (if (null match)
1475                     pair
1476                     (cons tag
1477                           (comb tag (cdr pair) (cdr match))))
1478                 list)))
1479       (dolist (pair b)
1480         (let* ((tag (car pair))
1481                (match (assoc tag a)))
1482           (unless match
1483             (push pair list))))
1484       (nreverse list))))
1485
1486 (defun combine (spec &rest lists)
1487   (reduce (lambda (x y) (combine2 spec x y)) lists))
1488
1489 (defun treasure (types)
1490   (apply #'combine
1491          combine-treasures
1492          (loop for type in types
1493                collect (treasure-type type))))
1494
1495 (defun select-spells (table spells)
1496   (loop for n in spells
1497         for list across table
1498         collect (sort (loop repeat n collect (apply #'choose-uniformly list))
1499                       #'string<)))