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

   1 (defun decode-percent-table (table)
   2   (let ((base 0))
   3     (mapcar (lambda (i)
   4               (prog1
   5                   (cons (- (car i) base) (cdr i))
   6                 (setf base (car i))))
   7             table)))
   8
   9 (defparameter weapons
  10   '((  9  "Axe, battle")
  11     ( 15  "Axe, hand")
  12     ( 17  "Axe, hand (returning)")
  13     ( 20  "Blackjack")
  14     ( 22  "Bola")
  15     ( 23  "Bola (returning)")
  16     ( 28  "Club")
  17     ( 40  "Dagger")
  18     ( 43  "Dagger (returning)")
  19     ( 53  "Hammer, war")
  20     ( 56  "Hammer, war (returning)")
  21     ( 59  "Javelin")
  22     ( 60  "Javelin (returning)")
  23     ( 64  "Lance")
  24     ( 76  "Mace")
  25     ( 78  "Net")
  26     ( 79  "Net (returning)")
  27     ( 84  "Polearm")
  28     ( 94  "Spear")
  29     ( 97  "Spear (returning)")
  30     (100  "Whip")))
  31
  32 (defparameter new-weapons
  33   '((9 "D" "Axe, battle")
  34     (6 "B" "Axe, hand")
  35     (2 "B" "Axe, hand (returning)")
  36     (3 "C" "Blackjack")
  37     (2 "B" "Bola")
  38     (1 "B" "Bola (returning)")
  39     (5 "C" "Club")
  40     (12 "B" "Dagger")
  41     (3 "B" "Dagger (returning)")
  42     (4 "C" "Flail, one-handed")
  43     (2 "D" "Flail, two-handed")
  44     (3 "D" "Halberd")
  45     (10 "C" "Hammer, war")
  46     (3 "B" "Javelin")
  47     (1 "B" "Javelin (returning)")
  48     (4 "D" "Lance")
  49     (7 "C" "Mace")
  50     (5 "C" "Morning star")
  51     (2 "B" "Net")
  52     (1 "B" "Net (returning)")
  53     (3 "D" "Pike")
  54     (2 "D" "Pole axe")
  55     (10 "B" "Spear")
  56     (3 "B" "Spear (returning)")
  57     (3 "C" "Whip")))
  58
  59 (defun normalize-percent-table (table)
  60   (let* ((max (reduce #'+ (mapcar #'car table)))
  61          (aug (mapcar (lambda (i)
  62                         (let* ((ideal (* 100 (/ (car i) max)))
  63                                (actual (max 1 (round ideal))))
  64                           (list* (- actual ideal) actual (cdr i))))
  65                       table))
  66          (tot (reduce #'+ (mapcar #'cadr aug))))
  67     (loop
  68       (let ((dir (signum (- 100 tot)))
  69             (best nil)
  70             (best-diff nil)
  71             (nbest 0))
  72         (when (zerop dir)
  73           (return))
  74         (dolist (i aug)
  75           (when (> (cadr i) 1)
  76             (let ((diff (abs (- (car i) dir))))
  77               (cond ((or (null best-diff) (< diff best-diff))
  78                      (setf best-diff diff
  79                            best i
  80                            nbest 1))
  81                     ((and (= diff best-diff)
  82                           (zerop (random (1+ nbest))))
  83                      (setf best i)
  84                      (incf nbest))))))
  85         (unless best
  86           (error "Can't normalize this table!"))
  87         (decf (car best) dir)
  88         (incf (cadr best) dir)
  89         (incf tot dir)))
  90     (mapcar #'cdr aug)))
  91
  92 (defun print-percent-table (table)
  93   (let* ((rangetab (let ((base 1))
  94                      (flet ((percentage (n)
  95                               (format nil "~@2,,,'0A"
  96                                       (if (= n 100) 0 n))))
  97                        (mapcar (lambda (i)
  98                                  (prog1
  99                                      (cons (if (= (car i) 1)
 100                                                (format nil "  ~A  "
 101                                                        (percentage base))
 102                                                (format nil "~A--~A"
 103                                                        (percentage base)
 104                                                        (percentage (+ base
 105                                                                       (car i)
 106                                                                       -1))))
 107                                            (mapcar #'princ-to-string
 108                                                    (cdr i)))
 109                                    (incf base (car i))))
 110                                table))))
 111          (widths (reduce (lambda (acc item)
 112                            (format t "*** ~S~%" item)
 113                            (mapcar #'max acc (mapcar #'length item)))
 114                          rangetab
 115                          :initial-value (mapcar (constantly 0)
 116                                                 (car rangetab))))
 117          (linesep nil))
 118     (dolist (item rangetab)
 119       (when linesep
 120         (write-string " \\\\ \\hlx{+}")
 121         (terpri))
 122       (write-string "   ")
 123       (loop with sep = nil
 124             for w in widths
 125             and i in item
 126             when sep do (format t " & ")
 127             do (format t "~vA" w i)
 128                (setf sep t))
 129       (setf linesep t))
 130     (when linesep
 131       (write-string " \\\\ \\hlx*{vh}")
 132       (terpri))))