;;;

(defun d (n &optional (k 1) &key (bias 0) best worst)
  (let ((rolls (sort (loop repeat k
			   collect (1+ (max 0 (min (1- n)
						   (+ (random n) bias)))))
		     #'<)))
    (reduce #'+ (cond (best (subseq rolls (- k best)))
		      (worst (subseq rolls 0 worst))
		      (t rolls)))))

(defvar *dnd-alist* nil)

(defun do-lookup (name default defaultp)
  (let ((item (assoc name *dnd-alist*)))
    (cond (item (cdr item))
	  (defaultp default)
	  (t (error "Missing required item ~S." name)))))

(defun lookup-list (name &optional (default nil defaultp))
  (do-lookup name default defaultp))

(defun lookup (name &optional (default nil defaultp))
  (car (do-lookup name (list default) defaultp)))

(defun hp-from-hd (&optional (hd (lookup-list :hit-dice)))
  (destructuring-bind (dice &key (plus 0) (stars 0)) hd
    (declare (ignore stars))
    (+ (cond ((zerop dice) 0)
	     ((= dice 1/8) 1)
	     ((= dice 1/4) (d 2))
	     ((= dice 1/2) (d 4))
	     ((and (integerp dice) (plusp dice)) (d 8 dice))
	     (t (error "Bad hit dice ~S." hd)))
       plus)))

(defun hd-table-lookup (hd table)
  (flet ((hd<= (a b)
	   (let ((aa (if (consp a) (car a) a))
		 (bb (if (consp b) (car b) b)))
	     (or (< aa bb)
		 (and (= aa bb)
		      (or (consp a)
			  (not (consp b))))))))
    (loop for ((lo . hi) . rest) in table
	  when (and (hd<= lo hd)
		    (hd<= hd hi))
	  return rest
	  finally (return nil))))

(let ((xp-table '(((  0    . (0 +))    5     1)
		  ((  1    .  1)      10     3)
		  ((( 1 +) . (1 +))   15     4)
		  ((  2    .  2)      20     5)
		  ((( 2 +) . (2 +))   25    10)
		  ((  3    .  3)      30    15)
		  ((( 3 +) . (3 +))   50    25)
		  ((  4    .  4)      75    50)
		  ((( 4 +) . (4 +))  125    75)
		  ((  5    .  5)     175   125)
		  ((( 5 +) . (5 +))  225   175)
		  ((  6    .  6)     275   225)
		  ((( 6 +) . (6 +))  350   300)
		  ((  7    .  7)     450   400)
		  ((( 7 +) . (7 +))  550   475)
		  ((  8    .  8)     650   550)
		  ((( 8 +) . (8 +))  775   625)
		  ((  9    .  9)     900   700)
		  ((( 9 +) . 10)    1000   750)
		  (((10 +) . 11)    1100   800)
		  (((11 +) . 12)    1250   875)
		  (((12 +) . 13)    1350   950)
		  (((13 +) . 14)    1500  1000)
		  (((14 +) . 15)    1650  1050)
		  (((15 +) . 16)    1850  1100)
		  (((16 +) . 17)    2000  1150)
		  (((17 +) . 18)    2125  1350)
		  (((18 +) . 19)    2250  1550)
		  (((19 +) . 20)    2375  1800)
		  (((20 +) . 21)    2500  2000))))
  (defun xp-from-hd (&optional (hd (lookup-list :hit-dice)))
    (destructuring-bind (dice &key (plus 0) (stars 0)) hd
      (multiple-value-bind (hd-base hd-plus)
	  (cond ((zerop plus) (values dice 0))
		((plusp plus) (values dice 1))
		((minusp plus) (values (1- dice) 1)))
	(let ((result (hd-table-lookup (if (zerop hd-plus)
					   hd-base
					   (list hd-base '+))
				     xp-table)))
	  (if result
	      (destructuring-bind (base bonus) result
		(+ base (* stars bonus)))
	      (let ((steps (+ hd-base -21 hd-plus)))
		(+ 2500
		   (* 250 steps)
		   (* (+ 2000 (* 250 steps)) stars)))))))))

(let ((thac0-table '(((  0      .   1) . 19)
		     ((( 1 . +) .   2) . 18)
		     ((( 2 . +) .   3) . 17)
		     ((( 3 . +) .   4) . 16)
		     ((( 4 . +) .   5) . 15)
		     ((( 5 . +) .   6) . 14)
		     ((( 6 . +) .   7) . 13)
		     ((( 7 . +) .   8) . 12)
		     ((( 8 . +) .   9) . 11)
		     ((( 9 . +) .  11) . 10)
		     (((11 . +) .  13) .  9)
		     (((13 . +) .  15) .  8)
		     (((15 . +) .  17) .  7)
		     (((17 . +) .  19) .  6)
		     (((19 . +) .  21) .  5)
		     (((21 . +) .  23) .  4)
		     (((23 . +) .  25) .  3)
		     (((25 . +) .  27) .  2)
		     (((27 . +) .  29) .  1)
		     (((29 . +) .  31) .  0)
		     (((31 . +) .  33) . -1)
		     (((33 . +) .  35) . -2))))
  (defun thac0-from-hd (&optional (hd (lookup-list :hit-dice)))
    (destructuring-bind (dice &key (plus 0) (stars 0)) hd
      (declare (ignore stars))
      (multiple-value-bind (hd-base hd-plus)
	  (cond ((zerop plus) (values dice 0))
		((plusp plus) (values dice 1))
		((minusp plus) (values (1- dice) 1)))
	(or (hd-table-lookup (if (zerop hd-plus)
				 hd-base
				 (list hd-base '+))
			     thac0-table)
	    -3)))))

(defparameter monster-template
  `((:hit-dice :required)
    (:thac0 :list ,#'thac0-from-hd)
    (:hit-points :list ,#'hp-from-hd)
    (:experience-points :list ,#'xp-from-hd)))

(defun apply-template (def tpl)
  (flet ((run (tag func)
	   (unless (assoc tag *dnd-alist*)
	     (push (cons tag (funcall func)) *dnd-alist*))))
    (loop with *dnd-alist* = def
	  for (tag key . tail) in tpl do
	  (case key
	    (:required (lookup-list tag))
	    (:eval (run tag (car tail)))
	    (:list (run tag (lambda () (list (funcall (car tail))))))
	    (t (run tag key)))
	  finally (return *dnd-alist*))))

(defun percentp (pc) (< (random 100) pc))

(defun bag (&rest things)
  (loop for i in things
	when i collect i))

(defun tagged-bag (tag &rest things)
  (let ((bag (apply #'bag things)))
    (and bag (cons tag bag))))

(defun choose (&rest things)
  (let ((n 0)
	(it nil))
    (do ((things things (cddr things)))
	((null things) it)
      (let ((k (car things)))
	(incf n k)
	(when (and (plusp n) (< (random n) k))
	  (setf it (cadr things)))))))

(defun choose-uniformly (&rest things)
  (let ((n 0) (it nil))
    (do ((things things (cdr things)))
	((null things) it)
	(incf n)
	(when (< (random n) 1)
	  (setf it (car things))))))

(defmacro pick (&body clauses)
  `(funcall (choose ,@(loop for (n . clause) in clauses
			   collect n
			   collect `(lambda () ,@clause)))))

(defmacro pick-matching ((form &key) &body clauses)
  (let ((formtemp (gensym "FORM")))
    `(let ((,formtemp ,form))
       (pick ,@(loop for (prob assertion . code) in clauses
		     collect `((if (assertion-match-p ,formtemp ',assertion)
				   ,prob
				   0)
			       ,@code))))))

(defconstant cleric-spells
  #((cure-light-wounds detect-evil detect-magic light protection-from-evil
     purify-food-and-water remove-fear resist-cold)
    (bless find-traps hold-person resist-fire silence-15-ft-radius
     slow-poison snake-charm speak-with-animal)
    (continual-light cure-blindness cure-disease growth-of-animals
     locate-object remove-curse speak-with-the-dead striking)
    (animate-dead create-water cure-serious-wounds dispel-magic
     neutralize-poison protection-from-evil-10-ft-radius speak-with-plants
     sticks-to-snakes)
    (commune create-food cure-critical-wounds dispel-evil insect-plague quest
     raise-dead truesight)
    (aerial-servant animate-objects barrier create-normal-animals cureall
     find-the-path speak-with-monsters word-of-recall)
    (earthquake holy-word raise-dead-fully restore survival travel wish
     wizardry)))

(defconstant druid-only-spells
  #((detect-danger faerie-fire locate predict-weather)
    (heat-metal obscure produce-fire warp-wood)
    (call-lightning hold-animal protection-from-poison water-breathing)
    (control-temperature-10-ft-radius plant-door protection-from-lightning
     summon-animals)
    (anti-plant-shell control-winds dissolve pass-plant)
    (anti-animal-shell summon-weather transport-through-plants turn-wood)
    (creeping-doom metal-to-wood summon-elemental weather-control)))

(defconstant druid-spells
  (make-array 7 :initial-contents (loop for cs across cleric-spells
					for ds across druid-only-spells
					collect (append cs ds))))

(defconstant magic-user-spells
  #((analyse charm-person detect-magic floating-disc hold-portal light
     magic-missile protection-from-evil read-languages read-magic shield
     sleep ventriloquism)
    (continual-light detect-evil detect-invisible entangle esp invisibility
     knock levitate locate-object mirror-image phantasmal-force web
     wizard-lock)
    (clairvoyance create-air dispel-magic fire-ball fly haste hold-person
     infravision invisibility-10-ft-radius lightning-bolt
     protection-from-evil-10-ft-radius protection-from-normal-missiles
     water-breathing)
    (charm-monster clothform confusion dimension-door growth-of-plants
     hallucinatory-terrain ice-storm/wall massmorph polymorph-others
     polymorph-self remove-curse wall-of-fire wizard-eye)
    (animate-dead cloudkill conjure-elemental contact-outer-plane dissolve
     feeblemind hold-monster magic-jar pass-wall telekinesis teleport
     wall-of-stone woodform)
    (anti-magic-shell death-spell disintegrate geas invisible-stalker
     lower-water move-earth projected-image reincarnation stone-to-flesh
     stoneform wall-of-iron weather-control)
    (charm-plant create-normal-monsters delayed-blast-fire-ball ironform lore
     magic-door mass-invisibility power-word-stun reverse-gravity statue
     summon-object sword teleport-any-object)
    (clone create-magical-monsters dance explosive-cloud force-field
     mass-charm mind-barrier permanence polymorph-any-object power-word-blind
     steelform symbol travel)
    (contingency create-any-monster gate heal immunity maze meteor-swarm
     power-word-kill prismatic-wall shapechange survival timestop wish)))

(defun spell-caster-type (&optional (form :any))
  (pick-matching (form)
    (5 (:user (:cleric :druid :paladin)) :cleric)
    (1 (:user :druid) :druid)
    (14 (:user (:magic-user :elf :thief)) :magic-user)))

(defun random-spell (&optional (caster (spell-caster-type))
		               (level (ecase caster
					((:magic-user) (choose 28 1
							       21 2
							       15 3
							       11 4
							        9 5
								7 6
								5 7
								3 8
								1 9))
					((:cleric :druid) (choose 34 1
								  24 2
								  18 3
								  12 4
								   7 5
								   4 6
								   1 7)))))
  (let ((list (aref (ecase caster
		      ((:magic-user) magic-user-spells)
		      ((:cleric) cleric-spells)
		      ((:druid) druid-only-spells))
		    level)))
    (values (elt list (random (length list)))
	    caster
	    level)))

(let ((magic (list :magic)))
  (defun assertion-match-p (form assertions)
    (cond ((eq form :any) t)
	  ((eq form :none) nil)
	  ((atom form) (if (atom assertions)
			   (eql form assertions)
			   (member form assertions)))
	  (t (case (car form)
	       ((and) (every (lambda (f)
			       (assertion-match-p f assertions))
			     (cdr form)))
	       ((or) (some (lambda (f)
			     (assertion-match-p f assertions))
			   (cdr form)))
	       ((not) (not (assertion-match-p (cadr form) assertions)))
	       (t (let ((sub (getf assertions (car form) magic)))
		    (if (eq sub magic)
			t
			(assertion-match-p (cadr form) sub)))))))))

(defun choose-distinct-items (n seq)
  (let* ((copy (subseq (coerce seq 'vector) 0))
	 (len (length copy))
	 (list nil))
    (dotimes (i n (sort list #'string<))
      (let ((j (random len)))
	(push (aref copy j) list)
	(decf len)
	(setf (aref copy j) (aref copy len))))))

(defun magic-item (form)
  (labels ((cursedp (&optional (prob 10))
	     (cond ((assertion-match-p form '(:cursed :unspecified))
		    (zerop (random prob)))
		   ((assertion-match-p form '(:cursed nil))
		    nil)
		   (t t)))
	   (potion (&key recursivep)
	     (pick-matching (form)
	       (2 (:cursed nil) `(:potion agility))
	       (1 (:cursed nil) `(:potion animal-control))
	       (3 (:cursed nil) `(:potion antidote))
	       (2 (:cursed nil) `(:potion blending))
	       (2 (:cursed nil) `(:potion bug-repellent))
	       (2 (:cursed nil) `(:potion clairaudience))
	       (2 (:cursed nil) `(:potion clairvoyance))
	       (2 (:cursed nil) `(:potion climbing))
	       (2 (:cursed nil) `(:potion defence :bonus ,(choose 3 1
								  2 2
								  2 3
								  2 4
								  1 5)))
	       ((if recursivep 0 4) (:cursed t)
		(setf form :any)
		`(:potion delusion
		  :fakes ,@(cdr (potion :recursivep t))))
	       (2 (:cursed nil) `(:potion diminution))
	       (1 (:cursed nil) `(:potion ,(choose 35 'white-dragon-control
						   15 'crystal-dragon-control
						   35 'black-dragon-control
						   15 'onyx-dragon-control
						   28 'green-dragon-control
						   12 'jade-dragon-control
						   21 'blue-dragon-control
						   9 'sapphire-dragon-control
						   14 'red-dragon-control
						   6 'ruby-dragon-control
						   7 'gold-dragon-control
						   3 'amber-dragon-control)))
	       (2 (:cursed nil) `(:potion dreamspeech))
	       (1 (:cursed nil) `(:potion elasicity))
	       (2 (:cursed nil) `(:potion ,(choose-uniformly 'air-form
							     'water-form
							     'earth-form
							     'fire-form)))
	       (2 (:cursed nil) `(:potion esp))
	       (1 (:cursed nil) `(:potion ethereality))
	       (3 (:cursed nil) `(:potion fire-resistance))
	       (3 (:cursed nil) `(:potion flying))
	       (2 (:cursed nil) `(:potion fortitude))
	       (1 (:cursed nil) `(:potion freedom))
	       (3 (:cursed nil) `(:potion gaseous-form))
	       (1 (:cursed nil) `(:potion ,(choose 5 'hill-giant-control
						   5 'stone-giant-control
						   4 'frost-giant-control
						   2 'fire-giant-control
						   1 'mountain-giant-control
						   1 'sea-giant-control
						   1 'cloud-giant-control
						   1 'storm-giant-control)))
	       (3 (:cursed nil) `(:potion giant-strength))
	       (2 (:cursed nil) `(:potion growth))
	       (6 (:cursed nil) `(:potion healing))
	       (3 (:cursed nil) `(:potion heroism))
	       (1 (:cursed nil) `(:potion human-control))
	       (3 (:cursed nil) `(:potion invisibility))
	       (2 (:cursed nil) `(:potion invulnerability))
	       (2 (:cursed nil) `(:potion levitation))
	       (2 (:cursed nil) `(:potion longevity))
	       (1 (:cursed nil) `(:potion luck))
	       (1 (:cursed nil) `(:potion merging))
	       (2 (:cursed nil) `(:potion plant-control))
	       (3 (:cursed t) `(:potion poison))
	       (3 (:cursed nil) `(:potion polymorph-self))
	       (2 (:cursed nil) `(:potion sight))
	       (2 (:cursed nil) `(:potion speech))
	       (4 (:cursed nil) `(:potion speed))
	       (2 (:cursed nil) `(:potion strength))
	       (3 (:cursed nil) `(:potion super-healing))
	       (3 (:cursed nil) `(:potion swimming))
	       (1 (:cursed nil) `(:potion treasure-finding))
	       (1 (:cursed nil) `(:potion undead-control))
	       (2 (:cursed nil) `(:potion water-breathing))))
	   (scroll ()
	     (pick-matching (form)
	       (3 (:cursed nil) `(:scroll communication))
	       (2 (:cursed nil) `(:scroll creation))
	       (8 (:cursed t) `(:scroll curse))
	       (1 (:user (:cleric :druid :magic-user :elf :thief :paladin)
		   :cursed nil)
		  (multiple-value-bind
		      (spell caster level)
		      (random-spell (spell-caster-type form))
		    (declare (ignore level))
		    `(:scroll delay :caster ,caster :spells (,spell))))
	       (3 (:cursed nil)
		  `(:scroll equipment
		    :items ,(choose-distinct-items 6
						   '(grappling-hook
						     hammer
						     iron-spikes
						     lantern
						     mirror
						     wooden-pole
						     rope
						     saddle
						     backpack
						     saddle-bags
						     stakes-and-mallet
						     wolfsbane))))
	       (2 (:cursed nil) `(:scroll illumination))
	       (2 (:cursed nil :user (:magic-user :cleric :druid :elf))
		  `(:scroll mages))
	       (4 (:cursed nil) `(:map normal-treasure))
	       (3 (:cursed nil) `(:map magical-treasure))
	       (2 (:cursed nil) `(:map combined-treasure))
	       (1 (:cursed nil) `(:map special-treasure))
	       (3 (:cursed nil) `(:scroll mapping))
	       (2 (:cursed nil) `(:scroll portals))
	       (6 (:cursed nil) `(:scroll protection-from-elementals))
	       (8 (:cursed nil) `(:scroll protection-from-lycanthropes))
	       (4 (:cursed nil) `(:scroll protection-from-magic))
	       (7 (:cursed nil) `(:scroll protection-from-undead))
	       (2 (:cursed nil) `(:scroll questioning))
	       (1 (:cursed nil
		   :user (:cleric :druid :magic-user :elf :thief :paladin))
		  (multiple-value-bind
		      (spell caster level)
		      (random-spell (spell-caster-type form))
		    `(:scroll repetition
		      :caster ,caster
		      :level ,level
		      :spells (,spell))))
	       (2 (:cursed nil) `(:scroll seeing))
	       (2 (:cursed nil) `(:scroll shelter))
	       (3 (:cursed nil)
		  `(:scroll spell-catching :max-level ,(choose 4 1
							       3 2
							       2 3
							       1 8)))
	       (25 (:cursed nil
		    :user (:cleric :druid :magic-user :elf :thief :paladin))
		   (let ((caster (spell-caster-type form))
			 (spells (choose 50 1  33 2  17 3)))
		     `(:scroll spell
		       :caster ,caster
		       :spells ,(loop repeat spells
				      collect (random-spell caster)))))
	       (2 (:cursed nil) `(:scroll trapping))
	       (2 (:cursed nil) `(:scroll truth))))
	   (wand-charges () (d 10 3))
	   (staff-charges () (d 20 2))
	   (wandlike ()
	     (pick-matching (form)
	       (5 (:user (:magic-user :elf))
		  `(:wand cold :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand enemy-detection :charges ,(wand-charges)))
	       (4 (:user (:magic-user :elf))
		  `(:wand fear :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand fireballs :charges ,(wand-charges)))
	       (4 (:user (:magic-user :elf))
		  `(:wand illusion :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand lightning-bolts :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand magic-detection :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand metal-detection :charges ,(wand-charges)))
	       (4 (:user (:magic-user :elf))
		  `(:wand negation :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand paralysation :charges ,(wand-charges)))
	       (5 (:user (:magic-user :elf))
		  `(:wand polymorphing :charges ,(wand-charges)))
	       (4 (:user (:magic-user :elf))
		  `(:wand secret-door-detection :charges ,(wand-charges)))
	       (4 (:user (:magic-user :elf))
		  `(:wand trap-detection :charges ,(wand-charges)))
	       (1 (:user (:magic-user :elf :cleric :druid :palatin))
		  `(:staff commanding :charges nil))
	       (2 nil
		  `(:staff dispelling :charges ,(staff-charges)))
	       (3 (:user :druid)
		  `(:staff druids :charges ,(staff-charges)))
	       (3 (:user (:magic-user :elf))
		  `(:staff ,(choose 19 'air
				    19 'earth
				    19 'fire
				    19 'water
				    6 'air-and-water
				    6 'earth-and-fire
				    2 'elemental-power)
		    :charges ,(staff-charges)))
	       (2 (:user (:cleric :druid :paladin))
		  `(:staff harming :charges ,(staff-charges)))
	       (7 (:user (:cleric :druid :paladin))
		  `(:staff healing :charges ,(staff-charges)))
	       (1 (:user (:cleric :druid :magic-user :elf :paladin))
		  `(:staff power :charges ,(staff-charges)))
	       (3 (:user (:cleric :druid :paladin))
		  `(:staff snake :charges ,(staff-charges)))
	       (3 (:user (:cleric :druid :magic-user :elf :paladin))
		  `(:staff striking :charges ,(staff-charges)))
	       (2 (:user (:cleric :druid :paladin))
		  `(:staff withering :charges ,(staff-charges)))
	       (1 (:user (:magic-user :elf))
		  `(:staff wizardry :charges ,(staff-charges)))
	       (2 nil `(:rod cancellation))
	       (1 nil `(:rod dominion))
	       (1 (:user (:cleric :druid :paladin)) `(:rod health))
	       (2 (:user (:dwarf :halfling :elf :fighter
			  :paladin :thief :mystic))
		  `(:rod inertia))
	       (1 nil `(:rod parrying))
	       (1 nil `(:rod victory))
	       (3 (:user (:dwarf :halfling :elf :fighter
			  :paladin :thief :mystic))
		  `(:rod weaponry))
	       (1 nil
		  `(:rod wyrm :colour ,(choose 5 'gold
					       3 'blue
					       2 'black)))))
	   (ring (&optional (recursivep nil))
	     (pick-matching (form)
	       (2 (:cursed nil) `(:ring animal-control))
	       ((if recursivep 0 6)
		(:cursed t)
		(setf form :any)
		`(:ring delusion :fakes ,@(cdr (ring t))))
	       (1 (:cursed nil) `(:ring djinni-summoning))
	       (4 (:cursed nil) `(:ring ear))
	       (4 (:cursed nil) `(:ring ,(choose 19 'air-adaptation
						 19 'earth-adaptation
						 19 'fire-adaptation
						 19 'water-adaptation
						 6 'air-and-water-adaptation
						 6 'earth-and-fire-adaptation
						 2 'elemental-adaptation)))
	       (6 (:cursed nil) `(:ring fire-resistance))
	       (3 (:cursed nil :user (:cleric :druid :paladin))
		  `(:ring holiness))
	       (1 (:cursed nil) `(:ring human-control))
	       (5 (:cursed nil) `(:ring invisibility))
	       (3 (:cursed nil) `(:ring life-protection :charges ,(d 6)))
	       (3 (:cursed nil
		   :user (:cleric :druid :magic-user :elf :paladin))
		  `(:ring memory))
	       (2 (:cursed nil) `(:ring plant-control))
	       (1 (:cursed nil) `(:ring protection :bonus 1 :radius 5))
	       (10 (:cursed nil) `(:ring protection :bonus ,(choose 4 1
								    3 2
								    2 3
								    1 4)))
	       (4 (:cursed nil) `(:ring quickness))
	       (1 (:cursed nil) `(:ring regeneration))
	       (3 (:cursed nil) `(:ring remedies))
	       (2 (:cursed nil) `(:ring safety :charges ,(d 4)))
	       (3 (:cursed nil) `(:ring seeing))
	       (3 (:cursed t) `(:ring spell-eating))
	       (2 (:cursed nil)
		  (let* ((caster (spell-caster-type))
			 (spells (loop repeat (d 6)
				       collect (random-spell caster))))
		    `(:ring spell-storing
		      :caster ,caster
		      :spells ,(remove-duplicates (sort spells
							#'string<)))))
	       (2 (:cursed nil) `(:ring spell-turning))
	       (4 (:cursed nil) `(:ring survival :charges ,(+ 100 (d 100))))
	       (2 (:cursed nil) `(:ring telekinesis))
	       (4 (:cursed nil) `(:ring truth))
	       (3 (:cursed t) `(:ring truthfulness))
	       (2 (:cursed t) `(:ring truthlessness))
	       (5 (:cursed nil) `(:ring water-walking))
	       (5 (:cursed t) `(:ring weakness))
	       (2 (:cursed nil) `(:ring wishes :charges ,(choose 4 1
								 3 2
								 2 3
								 1 4)))
	       (2 (:cursed nil) `(:ring x-ray-vision))))
	   (misc-item ()
	     (pick-matching (form)
	       (2 (:cursed nil)
		  `(:amulet protection-from-crystal-balls-and-esp))
	       (2 (:cursed t) `(:bag devouring))
	       (5 (:cursed nil) `(:bag holding))
	       (3 (:cursed nil) `(:boat undersea))
	       (2 (:cursed nil) `(:boots levitation))
	       (3 (:cursed nil) `(:boots speed))
	       (2 (:cursed nil) `(:boots travelling-and-leaping))
	       (1 (:cursed nil) `(:bowl commanding-water-elementals))
	       (1 (:cursed nil) `(:brazier commanding-fire-elementals))
	       (2 (:cursed nil) `(:broom flying))
	       (1 (:cursed nil) `(:censer controlling-air-elementals))
	       (3 (:cursed nil) `(:chime time))
	       (2 (:cursed nil :user (:magic-user :elf))
		  `(:crystal-ball normal))
	       (1 (:cursed nil :user (:magic-user :elf))
		  `(:crystal-ball clairaudience))
	       (1 (:cursed nil :user (:magic-user :elf))
		  `(:crystal-ball esp))
	       (2 (:cursed nil) `(:cloak displacer))
	       (1 (:cursed nil) `(:drums panic))
	       (1 (:cursed nil) `(:bottle efreeti))
	       (3 (:cursed nil) `(:egg ,(choose-uniformly 'rock-baboon
							  'giant-bat
							  'black-bear
							  'grizzly-bear
							  'boar
							  'mountain-lion
							  'panther
							  'giant-ferret
							  'gecko
							  'draco
							  'racer-snake
							  'wolf)))
	       (2 (:cursed nil) `(:boots elven))
	       (2 (:cursed nil) `(:cloak elven))
	       (1 (:cursed nil) `(:carpet flying))
	       (2 (:cursed nil) `(:gauntlets ogre-power))
	       (2 (:cursed nil) `(:girdle giant-strength))
	       (2 (:cursed t)
		  `(:helm ,(choose-uniformly 'lawful-alignment
					     'neutral-alignment
					     'chaotic-alignment)))
	       (2 (:cursed nil) `(:helm reading))
	       (1 (:cursed nil) `(:helm telepathy))
	       (1 (:cursed nil) `(:helm teleportation))
	       (1 (:cursed nil) `(:horn blasting))
	       (2 (:cursed t) `(:lamp hurricane))
	       (3 (:cursed nil) `(:lamp long-burning))
	       (2 (:cursed nil) `(:medallion esp-30-ft-range))
	       (1 (:cursed nil) `(:medallion esp-90-ft-range))
	       (1 (:cursed nil) `(:mirror life-trapping))
					; fixme include contents
	       (3 (:cursed nil) `(:muzzle training))
	       (2 (:cursed nil) `(:nail finger))
	       (3 (:cursed nil) `(:nail pointing))
	       (5 nil `(:ointment ,(pick-matching (form)
				     (1 (:cursed nil) 'blessing)
				     (1 (:cursed nil) 'healing)
				     (1 (:cursed t) 'poison)
				     (1 (:cursed t) 'scarring)
				     (1 (:cursed nil) 'soothing)
				     (1 (:cursed t) 'tanning))))
	       (3 (:cursed nil) `(:pouch security))
	       (3 (:cursed nil :user (:cleric :druid :magic-user :elf))
		  `(:quill copying))
	       (4 (:cursed nil) `(:rope climbing))
	       (2 (:cursed nil) `(:scarab protection :charges ,(d 6 2)))
	       (3 (:cursed nil :user (:cleric :druid :magic-user :elf))
		  `(:slate identification))
	       (1 (:cursed nil) `(:stone controlling-earth-elementals))
	       (2 (:cursed nil)
		  `(:talisman ,(choose-uniformly 'air-travel
						 'earth-travel
						 'fire-travel
						 'water-travel
						 'elemental-travel)))
	       (3 (:cursed nil) `(:wheel floating))
	       (1 (:cursed nil) `(:wheel fortune))
	       (2 (:cursed nil) `(:wheel square))))
	   (weapon-bonus (class)
	     (loop for bonus from 1
		   for roll = (random 100) then (- roll item)
		   for item in (ecase class
				 ((a) '(40 27 17 10 6))
				 ((b) '(50 24 14 8 4))
				 ((c) '(60 21 11 6 2))
				 ((d) '(70 18 8 3 1)))
		   when (< roll item) return bonus))
	   (armour-size ()
	     (pick-matching (form)
	       (68 (:user (:cleric :fighter :paladin :druid :thief)) 'human)
	       (13 (:user :dwarf) 'dwarf)
	       (10 (:user :elf) 'elf)
	       (7 (:user :halfling) 'halfling)
	       (2 (:user nil) 'giant)))
	   (armour-piece (class)
	     (let* ((bonus (weapon-bonus class))
		    (power (and (percentp (* 5 (1+ bonus)))
				(pick (7 `(absorption))
				      (10 `(charm))
				      (15 `(cure-wounds))
				      (10 `(electricity))
				      (5 `(energy-drain))
				      (3 `(ethereality))
				      (10 `(fly))
				      (6 `(gaseous-form))
				      (9 `(haste))
				      (10 `(invisibility))
				      (8 `(reflection))
				      (7 `(remove-curse :charges ,(d 3))))))
		    (cursedp (if (and power (eq (car power) 'remove-curse))
				 nil
				 (cursedp 8))))
	       `(:bonus ,bonus
		 ,@(and power (cons :power power))
		 :size ,(armour-size)
		 ,@(and cursedp `(:cursed t)))))
	   (armour ()
	     (pick-matching (form)
	       (10 (:user (:cleric :fighter :paladin :druid :thief
			   :dwarf :elf :halfling))
		   `((:armour leather ,@(armour-piece 'd))))
	       ( 7 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour scale-mail ,@(armour-piece 'd))))
	       (13 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour chain-mail ,@(armour-piece 'c))))
	       ( 9 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour banded-mail ,@(armour-piece 'd))))
	       (11 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour plate-mail ,@(armour-piece 'b))))
	       ( 5 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour suit ,@(armour-piece 'b))))
	       (20 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:shield ,@(armour-piece 'a))))
	       ( 2 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour scale-mail ,@(armour-piece 'd))
		     (:shield ,@(armour-piece 'a))))
	       ( 8 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour chain-mail ,@(armour-piece 'c))
		     (:shield ,@(armour-piece 'a))))
	       ( 5 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour banded-mail ,@(armour-piece 'd))
		     (:shield ,@(armour-piece 'a))))
	       (10 (:user (:cleric :fighter :paladin :dwarf :elf :halfling))
		   `((:armour plate-mail ,@(armour-piece 'b))
		     (:shield ,@(armour-piece 'a))))))
	   (opponent ()
	     (choose 6 'bugs
		     3 'constructs
		     6 'dragonkind
		     9 'enchanted-monsters
		     12 'giantkind
		     12 'lycanthropes
		     4 'planar-monsters
		     6 'regenerating-monsters
		     9 'reptiles-and-dinosaurs
		     3 'spell-immune-monsters
		     6 'spellcasters
		     12 'undead
		     6 'water-breathing-monsters
		     6 'weapon-using-monsters))
	   (weapon-talent (&key missilep)
	     (pick (5 `(breathing))
		   (7 `(charming))
		   (4 `(deceiving))
		   ((if missilep 0 7) `(defending))
		   (2 `(deflecting))
		   (2 `(draining :charges ,(+ 4 (d 4))))
		   (5 `(extinguishing))
		   (6 `(finding))
		   (5 `(flaming))
		   (3 `(flying))
		   (8 `(healing))
		   (5 `(hiding))
		   (6 `(holding))
		   (8 `(lightning))
		   (6 `(silencing))
		   (2 `(slicing))
		   (4 `(slowing))
		   (4 `(speeding))
		   (5 `(translating))
		   (5 `(watching))
		   (1 `(wishing :charges ,(d 3)))))
	   (weapon-modifier (bonus &rest keys &key &allow-other-keys)
	     (and (percentp (aref #(40 30 20 15 10) (1- bonus)))
		  (pick (33 `(:extra (,(+ bonus 1) :against ,(opponent))))
			(24 `(:extra (,(+ bonus 2) :against ,(opponent))))
			(16 `(:extra (,(+ bonus 3) :against ,(opponent))))
			(9 `(:extra (,(+ bonus 4) :against ,(opponent))))
			(3 `(:extra (,(+ bonus 5) :against ,(opponent))))
			(15 `(:talent ,@(apply #'weapon-talent keys))))))
	   (sword-modifier (bonus &rest keys &key &allow-other-keys)
	     (and (percentp (aref #(40 30 25 20 15) (1- bonus)))
		  (pick (29 `(:extra (,(+ bonus 1) :against ,(opponent))))
			(21 `(:extra (,(+ bonus 2) :against ,(opponent))))
			(14 `(:extra (,(+ bonus 3) :against ,(opponent))))
			(8 `(:extra (,(+ bonus 4) :against ,(opponent))))
			(3 `(:extra (,(+ bonus 5) :against ,(opponent))))
			(25 `(:talent ,@(apply #'weapon-talent keys))))))
	   (missile ()
	     (multiple-value-bind
		 (item class)
		 (pick-matching (form)
		   (37 (:user (:thief :fighter :paladin :mystic
			      :dwarf :elf :halfling))
		       (values :arrow 'a))
		   (22 (:user (:thief :fighter :paladin :mystic
				      :dwarf :elf :halfling))
		       (values :quarrel 'a))
		   (11 (:user (:cleric :druid :thief :fighter :paladin
			       :mystic :dwarf :elf :halfling))
		       (values :sling-stone 'a))
		   (2 (:user (:thief :fighter :paladin :mystic
			      :dwarf :elf :halfling))
		      (values :blowgun 'd))
		   (8 (:user (:thief :fighter :paladin :mystic
			      :dwarf :elf :halfling))
		      (values :long-bow 'd))
		   (5 (:user (:thief :fighter :paladin :mystic
			      :dwarf :elf :halfling))
		      (values :short-bow 'd))
		   (2 (:user (:thief :fighter :paladin :mystic
			      :dwarf :elf :halfling))
		      (values :heavy-crossbow 'd))
		   (5 (:user (:thief :fighter :paladin :mystic
			      :dwarf :elf :halfling))
		      (values :light-crossbow 'd))
		   (8 (:user (:cleric :druid :thief :fighter :paladin
			      :mystic :dwarf :elf :halfling))
		      (values :sling 'd)))
	       (ecase class
		 ((a) (let* ((bonus (weapon-bonus 'a))
			     (cursedp (zerop (random 10)))
			     (talent (and (percentp (* 5 (- 7 bonus)))
					  (pick (4 'biting)
						(5 'blinking)
						(5 'charming)
						(7 'climbing)
						(10 'curing)
						(3 'disarming)
						(4 'dispelling)
						(7 'flying)
						(7 'lightning)
						(5 'penetrating)
						(4 'refilling)
						(6 'screaming)
						(5 'seeking)
						(4 'sinking)
						(2 `(slaying
						     :opponent ,(opponent)))
						(7 'speaking)
						(4 'stunning)
						(2 'teleporting)
						(5 'transporting)
						(4 'wounding))))
			     (number (ecase bonus
				       ((1) (d 10 2))
				       ((2) (d 8 2))
				       ((3) (d 6 2))
				       ((4) (d 4 2))
				       ((5) (+ (d 4) 1)))))
			`(,item :bonus ,bonus
			  ,@(and talent `(:talent ,talent))
			  :number ,number
			  ,@(and cursedp `(:cursed t)))))
		 ((d) (let* ((bonus (weapon-bonus 'd))
			     (cursedp (cursedp 10))
			     (modifier (weapon-modifier bonus :missilep t))
			     (range (ecase (+ bonus (d 4))
				      ((2 3 4) nil)
				      ((5 6 7) 1.5)
				      ((8 9) 2))))
			`(,item :bonus ,bonus ,@modifier
			  ,@(and range `(:range ,range))
			  ,@(and cursedp `(:cursed t))))))))
	   (weapon-intelligence ()
	     (multiple-value-bind
		 (int langs prim read-magic-p extra)
		 (pick (79 (values nil 0 0 nil 0))
		       (6 (values 7 0 1 nil 0))
		       (5 (values 8 0 2 nil 0))
		       (4 (values 9 0 3 nil 0))
		       (3 (values 10 (d 3) 3 nil 0))
		       (2 (values 11 (d 6) 3 t 0))
		       (1 (values 12 (d 4 2) 3 t 1)))
	       (and int
		    (let ((powers nil)
			  (healing nil)
			  (damage nil)
			  (checklist nil))
		      (macrolet ((power-check (&rest forms)
				   `(pick ,@(loop for (tag n . form) in forms
						  if tag
						  collect
						  `((if (member ',tag
								checklist)
							0
							,n)
						    (push ',tag checklist)
						    ,@(or form
							  `((push ',tag
							     powers))))
						  else
						  collect `(,n ,@form)))))
			(labels ((primary-power ()
				   (power-check
				    (detect-evil 10)
				    (detect-gems 5)
				    (detect-magic 10)
				    (detect-metal 10)
				    (detect-shifting-walls-and-rooms 15)
				    (detect-sloping-passages 15)
				    (find-secret-doors 10)
				    (find-traps 10)
				    (see-invisible 10)
				    (:one-extra 4
				      (extraordinary-power))
				    (:two-primary 1
				      (primary-power)
				      (primary-power))))
				 (extraordinary-power ()
				   (power-check
				    (clairaudience 10)
				    (clairvoyance 10)
				    (esp 10)
				    (nil 5
				      (setf damage (if damage
						       (1+ damage)
						       5)))
				    (flying 5)
				    (nil 5
				      (setf healing (+ (or healing 0) 6)))
				    (illusion 9)
				    (levitation 5)
				    (telekinesis 10)
				    (telepathy 10)
				    (teleportation 9)
				    (x-ray-vision 9)
				    (:two-three-extra 2
				      (extraordinary-power)
				      (extraordinary-power))
				    (:two-three-extra 1
				      (extraordinary-power)
				      (extraordinary-power)
				      (extraordinary-power)))))
			  (dotimes (i prim) (primary-power))
			  (dotimes (i extra) (extraordinary-power))))
		      (when damage
			(push `(extra-damage ,damage) powers))
		      (when healing
			(push `(healing ,healing) powers))
		      `(:intelligence ,int
			:ego ,(d 12)
			:languages ,langs
			,@(and read-magic-p `(:read-magic t))
			:powers ,powers)))))
	   (sword ()
	     (multiple-value-bind
		 (type class)
		 (pick-matching (form)
		   (65 nil (values :normal-sword 'c))
		   (19 nil (values :short-sword 'c))
		   (8 (:user (:fighter :paladin :dwarf :mystic :elf))
		      (values :two-handed-sword 'd))
		   (8 (:user (:fighter :paladin :dwarf
			      :mystic :elf :halfling))
		      (values :bastard-sword 'd)))
	       (let* ((bonus (weapon-bonus class))
		      (cursedp (zerop (random 10)))
		      (modifier (sword-modifier bonus))
		      (intel (weapon-intelligence)))
		 `(,type :bonus ,bonus
		   ,@modifier
		   ,@intel
		   ,@(and cursedp `(:cursed t))))))
	   (weapon ()
	     (multiple-value-bind
		 (type returnsp intelpc class)
		 (pick-matching (form)
		   (7 (:user (:fighter :paladin :mystic :dwarf :elf))
		      (values :battle-axe nil 30 'd))
		   (8 (:user (:fighter :paladin :mystic :dwarf :thief
			      :elf :halfling))
		      (values :hand-axe (choose 3 nil 1 t) nil 'b))
		   (3 (:user (:fighter :paladin :mystic :dwarf :cleric
			      :elf :halfling))
		      (values :blackjack nil nil 'c))
		   (3 (:user (:fighter :paladin :mystic :dwarf :cleric
			      :thief :elf :halfling))
		      (values :bola (choose 2 nil 1 t) nil 'b))
		   (5 (:user (:fighter :paladin :mystic :dwarf
			      :thief :cleric :druid :elf :halfling))
		      (values :club nil nil 'c))
		   (14 (:user (:fighter :paladin :mystic :dwarf :magic-user
			       :thief :elf :halfling))
		       (values :dagger (choose 11 nil 3 t) 50 'b))
		   (4 (:user (:fighter :paladin :mystic :dwarf :cleric
			      :elf :halfling :thief))
		      (values :one-handed-flail nil nil 'c))
		   (2 (:user (:fighter :paladin :mystic :dwarf :cleric :elf))
		      (values :two-handed-flail nil nil 'd))
		   (3 (:user (:fighter :paladin :mystic :dwarf :elf))
		      (values :halberd nil 20 'd))
		   (8 (:user (:fighter :paladin :mystic :dwarf :cleric
			      :druid :elf :halfling :thief))
		      (values :war-hammer nil 30 'c))
		   (4 (:user (:fighter :paladin :mystic :dwarf :thief
			      :elf :halfling))
		      (values :javelin (choose 3 nil 1 t) nil 'b))
		   (4 (:user (:fighter :paladin :mystic :dwarf :elf))
		      (values :lance nil nil 'd))
		   (7 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
			      :elf :halfling :druid))
		      (values :mace nil 35 'c))
		   (5 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
			      :elf :halfling))
		      (values :morning-star nil nil 'c))
		   (3 (:user (:fighter :paladin :mystic :dwarf :cleric :thief
			      :druid :elf :halfling))
		      (values :net (choose 2 nil 1 t) nil 'b))
		   (3 (:user (:fighter :paladin :mystic :dwarf :elf))
		      (values :pike nil 20 'd))
		   (2 (:user (:fighter :paladin :mystic :dwarf :elf))
		      (values :pole-axe nil 20 'd))
		   (12 (:user (:fighter :paladin :mystic :dwarf :thief
			       :elf :halfling))
		       (values :spear (choose 3 nil 1 t) nil 'b))
		   (4 (:user (:fighter :paladin :mystic :dwarf :thief :cleric
			      :druid :elf :halfling :magic-user))
		      (values :staff nil 20 'd))
		   (3 (:user (:fighter :paladin :mystic :dwarf :thief :cleric
			      :druid :elf :halfling))
		      (values :whip nil nil 'c)))
	       (let* ((bonus (weapon-bonus class))
		      (cursedp (cursedp 10))
		      (modifier (sword-modifier bonus))
		      (intel (and intelpc
				  (percentp intelpc)
				  (weapon-intelligence))))
		 `(,type
		   ,@(and returnsp `(:returning t))
		   :bonus ,bonus
		   ,@modifier
		   ,@intel
		   ,@(and cursedp `(:cursed t)))))))
    (pick-matching (form)
      (25 (:type :potion) (list (potion)))
      (12 (:type :scroll) (list (scroll)))
      (9 (:type :wandlike :cursed nil) (list (wandlike)))
      (6 (:type :ring) (list (ring)))
      (10 (:type :misc) (list (misc-item)))
      (10 (:type :armour
	   :user (:cleric :druid :fighter :paladin
		  :thief :dwarf :elf :halfling))
	  (armour))
      (11 (:type :missile) (list (missile)))
      (9 (:type :sword
	  :user (:fighter :paladin :mystic :thief :dwarf :elf :halfling))
	 (list (sword)))
      (8 (:type :weapon) (list (weapon))))))

(defun treasure-type (type-code)
  (labels ((common-fur-type ()
	     (choose-uniformly 'beaver
			       'fox
			       'marten
			       'seal))
	   (rare-fur-type ()
	     (choose-uniformly 'ermine
			       'mink
			       'sable))
	   (special (n)
	     (cons
	      :special
	      (loop repeat n
		    collect
		    (pick (10 `(:kind book
				:value ,(* 10 (d 100))
				:encumbrance ,(d 100)))
			  (2 `(:kind pelt
			       :animal ,(common-fur-type)
			       :value ,(d 4)
			       :encumbrance ,(* 10 (d 6))))
			  (5 `(:kind cape
			       :animal ,(common-fur-type)
			       :value ,(* 100 (d 6))
			       :encumbrance ,(* 10 (+ 4 (d 8)))))
			  (3 `(:kind coat
			       :animal ,(common-fur-type)
			       :value ,(* 100 (d 4 3))
			       :encumbrance ,(* 10 (+ 8 (d 6 2)))))
			  (2 `(:kind pelt
			       :animal ,(rare-fur-type)
			       :value ,(d 6 2)
			       :encumbrance ,(* 10 (d 6))))
			  (5 `(:kind cape
			       :animal ,(rare-fur-type)
			       :value ,(* 100 (d 6 4))
			       :encumbrance ,(* 10 (+ 4 (d 8)))))
			  (3 `(:kind coat
			       :animal ,(rare-fur-type)
			       :value ,(* 1000 (d 4))
			       :encumbrance ,(* 10 (+ 8 (d 6 2)))))
			  (5 `(:kind incense
			       :value ,(d 6 5)
			       :encumbrance 1
			       :quantity ,(d 4 2)))
			  (5 `(:kind perfume
			       :value ,(* 10 (+ 5 (d 10)))
			       :encumbrance 1
			       :quantity ,(d 3 2)))
			  (5 (let ((w (d 6)) (h (d 2)))
			       `(:kind ,(choose-uniformly 'rug
							  'tapestry)
				 :value ,(* w h (d 10 2))
				 :encumbrance ,(* 100 w h (d 6))
				 :size (* ,w ,h))))
			  (10 (let ((w (d 8)) (h (d 2)))
				`(:kind silk
				  :value ,(* w h (d 8))
				  :encumbrance ,(* 10 w h (d 6))
				  :size (* ,w ,h))))
			  (10 `(:kind animal-skin
				:value ,(d 10)
				:encumbrance ,(* 10 (d 4 5))))
			  (10 `(:kind monster-skin
				:value ,(* 100 (d 10))
				:encumbrance ,(* 50 (d 100))))
			  (5 (let ((enc (d 100)))
			       `(:kind spice
				 :value ,(* enc (d 4 4))
				 :encumbrance ,enc)))
			  (5 `(:kind statuette
			       :value ,(* 100 (d 10))
			       :encumbrance ,(d 100)))
			  (5 `(:wine
			       :value ,(d 6)
			       :encumbrance ,(* 10 (+ 3 (d 6)))
			       :bottles ,(d 12)))))))
	   (gem-type (&key (min-value 0) recursivep)
	     (pick ((if (<= min-value 10) 3 0)
		    (values 10 (choose-uniformly 'agate
						 'quartz
						 'turquoise)))
		   ((if (<= min-value 50) 7 0)
		    (values 50 (choose-uniformly 'crystal
						 'jasper
						 'onyx)))
		   ((if (<= min-value 100) 15 0)
		    (values 100 (choose-uniformly 'amber
						  'amethyst
						  'coral
						  'garnet
						  'jade)))
		   ((if (<= min-value 500) 21 0)
		    (values 500 (choose-uniformly 'aquamarine
						  'pearl
						  'topaz)))
		   ((if (<= min-value 1000) 25 0)
		    (values 1000 (choose-uniformly 'carbuncle
						   'opal)))
		   ((if (<= min-value 5000) 19 0)
		    (values 5000 (choose-uniformly 'emerald
						   'ruby
						   'sapphire)))
		   ((if (<= min-value 10000) 7 0)
		    (values 10000 'diamond 'jacinth))
		   ((if (<= min-value 1000) 1 0)
		    (values (* 1000 (d 100))
			    'tristal))
		   ((if (and (not recursivep)
			     (<= min-value 2000)) 2 0)
		    (multiple-value-bind
			(value kind)
			(gem-type :min-value (max 1000
						  (ceiling min-value 2))
				  :recursivep t)
		      (values (* 2 value)
			      (intern (format nil "STAR-~A"
					      (string kind))))))))
	   (gems (n)
	     (cons
	      :gems
	      (loop while (plusp n)
		    for i = (min n (d 5))
		    do (decf n i)
		    collect
		    (let ((mods (choose 4 :size 4 :qual 2 :both))
			  (mod-list nil))
		      (multiple-value-bind
			  (value kind)
			  (gem-type)
			(when (or (eq mods :size)
				  (eq mods :both))
			  (multiple-value-bind
			      (mod mult)
			      (pick (1 (values 'very-small 1/8))
				    (2 (values 'small 1/4))
				    (2 (values 'fairly-small 1/2))
				    (2 (values 'fairly-large 2))
				    (2 (values 'large 4))
				    (1 (values 'very-small 8)))
			    (setf mod-list
				  (append `(:size ,mod) mod-list))
			    (setf value (* value mult))))
			(when (or (eq mods :qual)
				  (eq mods :both))
			  (multiple-value-bind
			      (mod mult)
			      (pick (1 (values 'very-poor 1/8))
				    (2 (values 'poor 1/4))
				    (2 (values 'fairly-poor 1/2))
				    (2 (values 'fairly-good 2))
				    (2 (values 'good 4))
				    (1 (values 'very-good 8)))
			    (setf mod-list
				  (append `(:quality ,mod) mod-list))
			    (setf value (* value mult))))
		      `(:kind ,kind
			:value ,(max 1 (round value))
			,@mod-list
			,@(and (> i 1) `(:quantity ,i))))))))
	   (jewellery (n)
	     (cons
	      :jewellery
	      (loop while (plusp n)
		    for i = (min n (d 5))
		    do (decf n i)
		    collect
		    (multiple-value-bind
			(value enc class)
			(pick ( 1 (values   100 10 'a))
			      ( 2 (values   500 10 'a))
			      ( 3 (values  1000 10 'a))
			      ( 4 (values  1500 10 'a))
			      ( 5 (values  2000 10 'a))
			      ( 8 (values  2500 10 'a))
			      (10 (values  3000 25 'a))
			      (11 (values  4000 25 'b))
			      (13 (values  5000 25 'b))
			      (11 (values  7500 25 'b))
			      ( 9 (values 10000 25 'b))
			      ( 7 (values 15000 25 'c))
			      ( 5 (values 20000 50 'c))
			      ( 4 (values 25000 50 'c))
			      ( 3 (values 30000 50 'c))
			      ( 2 (values 40000 50 'c))
			      ( 1 (values 50000 50 'c)))
		      (let ((kind (ecase class
				    ((a) (choose-uniformly 'anklet
							   'beads
							   'bracelet
							   'brooch
							   'buckle
							   'cameo
							   'chain
							   'clasp
							   'locket
							   'pin))
				    ((b) (choose-uniformly 'armband
							   'belt
							   'collar
							   'earring
							   'four-leaf-clover
							   'heart
							   'leaf
							   'necklace
							   'pendant
							   'rabbit-foot))
				    ((c) (choose-uniformly 'amulet
							   'crown
							   'diadem
							   'medallion
							   'orb
							   'ring
							   'scarab
							   'sceptre
							   'talisman
							   'tiara)))))
			`(:kind ,kind
			  :value ,value
			  :encumbrance ,enc
			  ,@(and (> i 1) `(:quantity ,i))))))))
	   (magic (&rest forms)
	     (cons :magic
		   (loop with list = nil
			 for (form n) on forms by #'cddr do
			 (loop repeat n do
			       (dolist (item (magic-item (list :type form)))
				 (push item list)))
			 finally (return list)))))
    (ecase type-code

      ;; treasure in lair
      ((a) (bag (tagged-bag :coins
			    (and (percentp 25) `(:cp ,(* 1000 (d 6))))
			    (and (percentp 30) `(:sp ,(* 1000 (d 6))))
			    (and (percentp 20) `(:ep ,(* 1000 (d 4))))
			    (and (percentp 35) `(:gp ,(* 1000 (d 6 2))))
			    (and (percentp 25) `(:pp ,(* 1000 (d 2)))))
		(and (percentp 50) (gems (d 6 6)))
		(and (percentp 50) (jewellery (d 6 6)))
		(and (percentp 10) (special (d 2)))
		(and (percentp 30) (magic :any 3))))
      ((b) (bag (tagged-bag :coins
			    (and (percentp 50) `(:cp ,(* 1000 (d 8))))
			    (and (percentp 25) `(:sp ,(* 1000 (d 6))))
			    (and (percentp 25) `(:ep ,(* 1000 (d 4))))
			    (and (percentp 35) `(:gp ,(* 1000 (d 3)))))
		(and (percentp 25) (gems (d 6)))
		(and (percentp 25) (jewellery (d 6)))
		(and (percentp 10)
		     (magic '(or :armour :missile :sword :weapon) 1))))
      ((c) (bag (tagged-bag :coins
			    (and (percentp 20) `(:cp ,(* 1000 (d 12))))
			    (and (percentp 30) `(:sp ,(* 1000 (d 4))))
			    (and (percentp 10) `(:ep ,(* 1000 (d 4)))))
		(and (percentp 50) (gems (d 6 6)))
		(and (percentp 50) (jewellery (d 6 6)))
		(and (percentp 5) (special (d 2)))
		(and (percentp 10) (magic :any 2))))
      ((d) (bag (tagged-bag :coins
			    (and (percentp 10) `(:cp ,(* 1000 (d 8))))
			    (and (percentp 15) `(:sp ,(* 1000 (d 12))))
			    (and (percentp 60) `(:gp ,(* 1000 (d 6)))))
		(and (percentp 30) (gems (d 8)))
		(and (percentp 30) (jewellery (d 8)))
		(and (percentp 10) (special (d 2)))
		(and (percentp 10) (magic :any 1 :potion 1))))
      ((e) (bag (tagged-bag :coins
			    (and (percentp 5) `(:cp ,(* 1000 (d 10))))
			    (and (percentp 30) `(:sp ,(* 1000 (d 12))))
			    (and (percentp 25) `(:ep ,(* 1000 (d 4))))
			    (and (percentp 25) `(:gp ,(* 1000 (d 8)))))
		(and (percentp 10) (gems (d 10)))
		(and (percentp 10) (jewellery (d 10)))
		(and (percentp 15) (special (d 2)))
		(and (percentp 25) (magic :any 3 :scroll 1))))
      ((f) (bag (tagged-bag :coins
			    (and (percentp 30) `(:sp ,(* 1000 (d 10 2))))
			    (and (percentp 20) `(:ep ,(* 1000 (d 8))))
			    (and (percentp 45) `(:gp ,(* 1000 (d 12))))
			    (and (percentp 30) `(:pp ,(* 1000 (d 3)))))
		(and (percentp 20) (gems (d 12 2)))
		(and (percentp 10) (jewellery (d 12)))
		(and (percentp 20) (special (d 3)))
		(and (percentp 30) (magic :potion 1 :scroll 1
					  '(not :armour :missile
					    :sword :weapon) 3))))
      ((g) (bag (tagged-bag :coins
			    (and (percentp 50) `(:gp ,(* 10000 (d 4))))
			    (and (percentp 50) `(:pp ,(* 1000 (d 6)))))
		(and (percentp 25) (gems (d 6 3)))
		(and (percentp 25) (jewellery (d 10)))
		(and (percentp 30) (special (d 3)))
		(and (percentp 35) (magic :any 4 :scroll 1))))
      ((h) (bag (tagged-bag :coins
			    (and (percentp 25) `(:cp ,(* 1000 (d 8 3))))
			    (and (percentp 50) `(:sp ,(* 1000 (d 100))))
			    (and (percentp 50) `(:ep ,(* 10000 (d 4))))
			    (and (percentp 50) `(:gp ,(* 10000 (d 6))))
			    (and (percentp 25) `(:pp ,(* 1000 (d 4 5)))))
		(and (percentp 50) (gems (d 100)))
		(and (percentp 50) (jewellery (* 10 (d 4))))
		(and (percentp 10) (special (d 2)))
		(and (percentp 15) (magic :any 4 :potion 1 :scroll 1))))
      ((i) (bag (tagged-bag :coins
			    (and (percentp 30) `(:pp ,(* 1000 (d 8)))))
		(and (percentp 50) (gems (d 6 2)))
		(and (percentp 50) (jewellery (d 6 2)))
		(and (percentp 5) (special (d 2)))
		(and (percentp 15) (magic :any 1))))
      ((j) (bag (tagged-bag :coins
			    (and (percentp 25) `(:cp ,(* 1000 (d 4))))
			    (and (percentp 10) `(:sp ,(* 1000 (d 3)))))))
      ((k) (bag (tagged-bag :coins
			    (and (percentp 30) `(:sp ,(* 1000 (d 6))))
			    (and (percentp 10) `(:ep ,(* 1000 (d 2)))))))
      ((l) (bag (and (percentp 50) (gems (d 4)))))
      ((m) (bag (and (percentp 55) (gems (d 4)))
		(and (percentp 45) (jewellery (d 6 2)))))
      ((n) (bag (and (percentp 10) (special (d 2)))
		(and (percentp 40) (magic :potion (d 4 2)))))
      ((o) (bag (and (percentp 10) (special (d 3)))
		(and (percentp 50) (magic :scroll (d 4)))))

      ;; treasure carried
      ((p) (bag (tagged-bag :coins `(:cp ,(d 8 3)))))
      ((q) (bag (tagged-bag :coins `(:sp ,(d 6 3)))))
      ((r) (bag (tagged-bag :coins `(:ep ,(d 6 2)))))
      ((s) (bag (tagged-bag :coins `(:gp ,(d 4 2)))
		(and (percentp 5) (gems 1))))
      ((t) (bag (tagged-bag :coins `(:pp ,(d 6 1)))
		(and (percentp 5) (gems 1))))
      ((u) (bag (tagged-bag :coins
			    (and (percentp 10) `(:cp ,(d 100)))
			    (and (percentp 10) `(:sp ,(d 100)))
			    (and (percentp 5) `(:gp ,(d 100))))
		(and (percentp 5) (gems (d 2)))
		(and (percentp 5) (gems (d 4)))
		(and (percentp 2) (special 1))
		(and (percentp 2) (magic :any 1))))
      ((v) (bag (tagged-bag :coins
			    (and (percentp 10) `(:sp ,(d 100)))
			    (and (percentp 5) `(:ep ,(d 100)))
			    (and (percentp 5) `(:gp ,(d 100)))
			    (and (percentp 5) `(:pp ,(d 100))))
		(and (percentp 10) (gems (d 2)))
		(and (percentp 10) (gems (d 4)))
		(and (percentp 5) (special 1))
		(and (percentp 5) (magic :any 1))))

      ;; unguarded treasures
      ((unguarded-1)
       (bag (tagged-bag :coins
			`(:sp ,(* 100 (d 6)))
			(and (percentp 50) `(:gp ,(* 10 (d 6)))))
	    (and (percentp 5) (gems (d 6)))
	    (and (percentp 2) (jewellery (d 6)))
	    (and (percentp 2) (magic :any 1))))
      ((unguarded-2 unguarded-3)
       (bag (tagged-bag :coins
			`(:sp ,(* 100 (d 12)))
			(and (percentp 50) `(:gp ,(* 100 (d 6)))))
	    (and (percentp 10) (gems (d 6)))
	    (and (percentp 5) (jewellery (d 6)))
	    (and (percentp 8) (magic :any 1))))
      ((unguarded-4 unguarded-5)
       (bag (tagged-bag :coins
			`(:sp ,(* 1000 (d 6)))
			`(:gp ,(* 200 (d 6))))
	    (and (percentp 20) (gems (d 8)))
	    (and (percentp 10) (jewellery (d 8)))
	    (and (percentp 10) (magic :any 1))))
      ((unguarded-6 unguarded-7)
       (bag (tagged-bag :coins
			`(:sp ,(* 2000 (d 6)))
			`(:gp ,(* 500 (d 6))))
	    (and (percentp 30) (gems (d 10)))
	    (and (percentp 15) (jewellery (d 10)))
	    (and (percentp 15) (magic :any 1))))
      ((unguarded-8 unguarded-9)
       (bag (tagged-bag :coins
			`(:sp ,(* 5000 (d 6)))
			`(:gp ,(* 1000 (d 6))))
	    (and (percentp 40) (gems (d 12)))
	    (and (percentp 20) (jewellery (d 12)))
	    (and (percentp 20) (magic :any 1)))))))

(defconstant combine-treasures
  '((:coins (t . +))
    (t . append)))

(defun combine2 (spec a b)
  (labels ((comb (tag x y)
	     (dolist (pair spec)
	       (let ((label (car pair)))
		 (when (or (eq label t)
			   (eq label tag))
		   (return-from comb
		     (let ((method (cdr pair)))
		       (etypecase method
			 (list (combine2 method x y))
			 ((member +) (list (+ (car x) (car y))))
			 ((or symbol function)
			  (funcall method x y))))))))
	     (error "No combiner found for ~S." tag)))
    (let ((list nil))
      (dolist (pair a)
	(let* ((tag (car pair))
	       (match (assoc tag b)))
	  (push (if (null match)
		    pair
		    (cons tag
			  (comb tag (cdr pair) (cdr match))))
		list)))
      (dolist (pair b)
	(let* ((tag (car pair))
	       (match (assoc tag a)))
	  (unless match
	    (push pair list))))
      (nreverse list))))

(defun combine (spec &rest lists)
  (reduce (lambda (x y) (combine2 spec x y)) lists))

(defun treasure (types)
  (apply #'combine
	 combine-treasures
	 (loop for type in types
	       collect (treasure-type type))))

(defun select-spells (table spells)
  (loop for n in spells
	for list across table
	collect (sort (loop repeat n collect (apply #'choose-uniformly list))
		      #'string<)))