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

   1 (defconstant xp-table
   2   '(((0 . (0 +))         5     1)
   3     ((1 . 1)            10     3)
   4     (((1 +) . (1 +))    15     4)
   5     ((2 . 2)            20     5)
   6     (((2 +) . (2 +))    25    10)
   7     ((3 . 3)            30    15)
   8     (((3 +) . (3 +))    50    25)
   9     ((4 . 4)            75    50)
  10     (((4 +) . (4 +))   125    75)
  11     ((5 . 5)           175   125)
  12     (((5 +) . (5 +))   225   175)
  13     ((6 . 6)           275   225)
  14     (((6 +) . (6 +))   350   300)
  15     ((7 . 7)           450   400)
  16     (((7 +) . (7 +))   550   475)
  17     ((8 . 8)           650   550)
  18     (((8 +) . (8 +))   775   625)
  19     ((9 . 9)           900   700)
  20     (((9 +) . 10)     1000   750)
  21     (((10 +) . 11)    1100   800)
  22     (((11 +) . 12)    1250   875)
  23     (((12 +) . 13)    1350   950)
  24     (((13 +) . 14)    1500  1000)
  25     (((14 +) . 15)    1650  1050)
  26     (((15 +) . 16)    1850  1100)
  27     (((16 +) . 17)    2000  1150)
  28     (((17 +) . 18)    2125  1350)
  29     (((18 +) . 19)    2250  1550)
  30     (((19 +) . 20)    2375  1800)
  31     (((20 +) . 21)    2500  2000)))
  32
  33 (defun parse-hd-spec (spec &optional start end)
  34   (unless start (setf start 0))
  35   (unless end (setf end (length spec)))
  36   (multiple-value-bind
  37       (hd e)
  38       (parse-integer spec :start start :end end :junk-allowed t)
  39     (when (and (< e end)
  40                (char= (char spec e) #\+))
  41       (incf e)
  42       (multiple-value-bind
  43           (hunoz ee)
  44           (parse-integer spec :start e :end end :junk-allowed t)
  45         (declare (ignore hunoz))
  46         (setf e ee)
  47         (setf hd (list hd '+))))
  48     (unless (loop for i from e below end
  49                   never (char/= (char spec i) #\*))
  50       (error "bad hit dice string"))
  51     (let ((stars (- end e)))
  52       (flet ((hd<= (a b)
  53                (let ((aa (if (consp a) (car a) a))
  54                      (bb (if (consp b) (car b) b)))
  55                  (or (< aa bb)
  56                      (and (= aa bb)
  57                           (or (consp a)
  58                               (not (consp b))))))))
  59         (loop for ((lo . hi) base bonus) in xp-table
  60               when (and (hd<= lo hd)
  61                         (hd<= hd hi))
  62               return (+ base (* stars bonus))
  63               finally (let* ((hd-base (if (consp hd) (car hd) hd))
  64                              (hd-plus (if (consp hd) 1 0))
  65                              (steps (+ hd-base -21 hd-plus)))
  66                         (return (+ 2500
  67                                    (* 250 steps)
  68                                    (* (+ 2000 (* 250 steps)) stars)))))))))
  69
  70 (defmacro hd (sym)
  71   `(parse-hd-spec ',(princ-to-string sym)))