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