Initial versions of things.

[dnd] / dice.lisp

;;;

(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*))))