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)))))
8 (reduce #'+ (cond (best (subseq rolls (- k best)))
9 (worst (subseq rolls 0 worst))
12 (defvar *dnd-alist* nil)
14 (defun do-lookup (name default defaultp)
15 (let ((item (assoc name *dnd-alist*)))
16 (cond (item (cdr item))
18 (t (error "Missing required item ~S." name)))))
20 (defun lookup-list (name &optional (default nil defaultp))
21 (do-lookup name default defaultp))
23 (defun lookup (name &optional (default nil defaultp))
24 (car (do-lookup name (list default) defaultp)))
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)
33 ((and (integerp dice) (plusp dice)) (d 8 dice))
34 (t (error "Bad hit dice ~S." hd)))
37 (defun hd-table-lookup (hd table)
39 (let ((aa (if (consp a) (car a) a))
40 (bb (if (consp b) (car b) b)))
45 (loop for ((lo . hi) . rest) in table
46 when (and (hd<= lo hd)
49 finally (return nil))))
51 (let ((xp-table '((( 0 . (0 +)) 5 1)
53 ((( 1 +) . (1 +)) 15 4)
55 ((( 2 +) . (2 +)) 25 10)
57 ((( 3 +) . (3 +)) 50 25)
59 ((( 4 +) . (4 +)) 125 75)
61 ((( 5 +) . (5 +)) 225 175)
63 ((( 6 +) . (6 +)) 350 300)
65 ((( 7 +) . (7 +)) 550 475)
67 ((( 8 +) . (8 +)) 775 625)
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)
92 (destructuring-bind (base bonus) result
93 (+ base (* stars bonus)))
94 (let ((steps (+ hd-base -21 hd-plus)))
97 (* (+ 2000 (* 250 steps)) stars)))))))))
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)
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)))
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
147 (:required (lookup-list tag))
148 (:eval (run tag (car tail)))
149 (:list (run tag (lambda () (list (funcall (car tail))))))
151 finally (return *dnd-alist*))))