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