Commits

Paul Sexton committed eea2571

First commit.

  • Participants

Comments (0)

Files changed (3)

+PTables
+=======
+
+Probability tables ("ptables") emulate (and surpass in functionality) the
+"levelled lists" that are used to randomly generate loot and encounters in the
+Elder Scrolls games.
+
+Each entry in a probability table or ptable associates a value with a numerical
+rarity (higher is more rare). Each value can be a lisp object or a link to
+another ptable, allowing nested ptables.
+
+## Defining ptables
+
+Ptables can be created using the "define-ptable" toplevel form, or can be built
+up piecewise. A "ptabled-class" metaclass is also provided which allows classes
+to insert entries for themselves into ptables.
+
+## Levels and ptables
+
+Each entry can also contain information about how its rarity should vary as a
+"level" parameter increases. This information includes a minimum level below
+which the value will not appear at all, and level values where the item should
+be maximally common.
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; coding: utf-8-unix -*- ;;;;;;;;80
+
+(defpackage #:ptable-system
+  (:use :cl :asdf))
+
+(in-package :ptable-system)
+
+(defsystem ptable
+    :name "PTable"
+    :version "1.0.0"
+    :author "Paul Sexton"
+    :description "Probability tables."
+    :long-description "Probability tables."
+    :serial t
+    :components ((:file "ptable"))
+    :depends-on ("alexandria"
+                 "iterate"
+                 "closer-mop"
+                 "fare-memoization"
+                 "defstar"))
+
+
+;;;; ptable.asd ends here  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; coding: utf-8-unix -*- ;;;;;;;;80
+
+(in-package :cl-user)
+
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+;;;; [[Ptable class]]
+;;;; [[Ptable entry class]]
+;;;; [[Rarity and probability functions]]
+;;;; [[External functions]]
+;;;; [[Ptabled classes]]
+
+
+(defpackage :ptable
+  (:use :cl
+        :alexandria
+        :iterate
+        :closer-mop
+        :fare-memoization
+        :defstar)
+  (:shadowing-import-from :closer-mop
+                          #:standard-generic-function
+                          #:slot-definition-initform
+                          #:defgeneric
+                          #:defclass
+                          #:defmethod
+                          #:standard-method
+                          #:ensure-generic-function
+                          #:standard-class)
+  (:export
+   #:ptable
+   #:ptable-name
+   #:ptable-entries
+   #:ptable-entry
+   #:pentry-item
+   #:pentry-count
+   #:pentry-rarity
+   #:pentry-min-level
+   #:pentry-peaks
+   #:symbol->ptable
+   #:random-entry
+   #:ptable-add-entry
+   #:ptable-replace-entry
+   #:ptable-contents
+   #:ptabled-class
+   #:ptabled-class?
+   #:all-ptable-entries))
+
+(in-package :ptable)
+
+
+(defgeneric ptable-contents (ptable))
+(defgeneric pentries-equal? (pentry1 pentry2))
+(defgeneric pentry-rarity (pentry))
+(defgeneric ptable-add-entry (ptable entry))
+(defgeneric ptable-replace-entry (ptable entry))
+(defgeneric rarity-at-level (pentry level))
+(defgeneric ptable-probabilities (ptable &key level? cumulative? flat?))
+(defgeneric random-entry (ptable &optional level))
+
+
+(defvar *ptables* (make-hash-table :test #'equal))
+
+
+(defparameter *ptable-rarities*
+  '((:common .           1)
+    (:uncommon .         3)
+    (:rare .             10)
+    (:very-rare .         50)))
+
+
+(defparameter *pentry-rarity-decay-factor* 2
+  "For pentries which have `peaks' in their frequencies. Frequency falls
+  exponentially as |level - peaklevel| increases, according to rarity * 1/(F^d)
+where F is the decay factor and d is the difference in levels. The default value
+of 2 means frequency halves for every 1 level of difference.  Reduce the number
+to make the decay more gradual.")
+
+
+(defmacro define-ptable (sym &body body)
+  "* Arguments
+- BODY :: consists of the forms (PTABLE-ENTRY) (PTABLE-ENTRY) ....
+- SYM :: names a new or existing ptable (if it does not exist it is
+created.) Each of the following PTABLE-ENTRIES is then added to the
+entries for the new ptable.
+
+* Returns:
+Two values:
+1. The symbol (name) of the ptable.
+2. The ptable object.
+
+Note: because the macro returns the ptable symbol, it can be included wherever
+a ptable-symbol can be included in class slot definitions etc.
+
+* Description
+There is usually no need to specify specific CLASSES in this variable;
+rather you should make the class inherit from PTABLED-CLASS, and put the ptable
+entry in the class definition. What this macro is for is:
+1. to define *nested* ptables - there is currently no other way
+   to do this.
+2. to define ptables that contain data other than ptabled-classes.
+3. Sometimes you will want to define the ptable in a single place, rather
+   than defining it using clauses scattered through the `ptable-entries' slots
+   of classes."
+  `(fn-define-ptable ,sym ',body))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun fn-define-ptable (sym entries)
+    (let ((tbl (symbol->ptable sym :make? t)))
+      (iterate
+        (for (item . body) in entries)
+        (ptable-replace-entry tbl entry))
+      (values sym tbl))))
+
+
+;;;; <<Ptable class>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define-class ptable ()
+  (ptable-name nil :initarg :name)
+  (ptable-entries nil))
+
+
+(defmethod print-object ((tbl ptable) strm)
+  (print-unreadable-object (tbl strm :type t)
+    (format strm "~S (~D entries)"
+            (ptable-name tbl)
+            (length (ptable-entries tbl)))
+    (dolist (pentry (ptable-entries tbl))
+      (format strm "~&  ~S" pentry))
+    (terpri strm)))
+
+
+;; `entries', if supplied, is a list of argument-lists. Each argument-list will
+;; be used to create a new ptable-entry instance.
+(defmethod initialize-instance :after ((tbl ptable) &key entries
+                                                    &allow-other-keys)
+  (when (ptable-name tbl)
+    (setf (gethash (ptable-name tbl) *ptables*) tbl))
+  (when entries
+    (setf (ptable-entries tbl)
+          (mapcar (lambda (entry) (apply #'make-instance
+                                    'ptable-entry entry))
+                  entries))))
+
+
+(defun symbol->ptable (sym &key (error? nil) (make? nil))
+  (typecase sym
+    (null (error ""))
+    (symbol (or (gethash sym *ptables*)
+                (cond
+                  (make? (make-instance 'ptable :name sym))
+                  (error? (error "There is no ptable named ~S" sym))
+                  (t nil))))))
+
+
+(defmethod ptable-contents ((tbl ptable))
+  (iterate
+    (for entry in (ptable-entries tbl))
+    (appending (if-let (tbl2 (symbol->ptable (pentry-item entry)))
+                       (ptable-contents tbl2)
+                       (list (pentry-item entry))))))
+
+
+
+;;;; <<Ptable entry class>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define-class ptable-entry ()
+  (pentry-item nil :initarg :item)
+  (pentry-count 1 :initarg :count)
+  (pentry-rarity 1 :accessor nil :initarg :rarity)
+  (pentry-min-level nil :initarg :min-level)
+  (pentry-peaks nil :type list :initarg :peaks :doc "List of levels where the
+item's commonness peaks. This can be a single number, or several numbers to
+provide multimodal distributions.")
+  (pentry-probability 0 :type (real 0 1)
+                        :doc "Probability 0-1 of picking this entry from the
+                        table."))
+
+
+(defmethod print-object ((pentry ptable-entry) strm)
+  (print-unreadable-object (pentry strm :type t)
+    (format strm "~S (count ~A, rarity ~A, min-level ~A, peaks ~A)"
+            (pentry-item pentry)
+            (pentry-count pentry)
+            (pentry-rarity pentry)
+            (pentry-min-level pentry)
+            (pentry-peaks pentry))))
+
+
+(defmethod pentries-equal? ((pe1 ptable-entry) (pe2 ptable-entry))
+  (and (equal (pentry-item pe1) (pentry-item pe2))
+       (equal (pentry-count pe1) (pentry-count pe2))))
+
+
+(defmethod pentry-rarity ((pentry ptable-entry))
+  (let ((rarity (slot-value pentry 'pentry-rarity)))
+    (typecase rarity
+      (symbol (cdr (assoc rarity *ptable-rarities*)))
+      (number rarity)
+      (otherwise (error "")))))
+
+
+(defmethod ptable-add-entry ((tbl ptable) (entry ptable-entry))
+  (push entry (ptable-entries tbl)))
+
+
+(defmethod ptable-add-entry ((tbl ptable) (entry list))
+  (call-next-method tbl (list-to-entry entry)))
+
+
+(defmethod ptable-replace-entry ((tbl ptable) (entry ptable-entry))
+  (pushnew entry (ptable-entries tbl) :key #'pentry-item :test #'equal))
+
+
+(defmethod ptable-replace-entry ((tbl ptable) (entry ptable-entry))
+  (call-next-method tbl (list-to-entry entry)))
+
+
+(defun list-to-entry ((entry list))
+  (cond
+    ((atom entry)
+     (error "Cannot make ptable-entry out of value `~S'" entry))
+    (t
+     (unless (and (evenp (length entry))
+                  (getf entry :item))
+       (push :item entry))
+     (apply #'make-instance 'ptable-entry entry))))
+
+
+
+;;;; <<Rarity and probability functions>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defgeneric* rarity-at-level (pentry level)
+  "Calculate PENTRY's rarity adjusted for level LEVEL.
+Returns a number, or NIL if the item cannot occur (is infinitely rare) at
+that level.")
+
+
+(defmethod rarity-at-level ((pentry ptable-entry) (lvl null))
+  (pentry-rarity pentry))
+
+
+(defmethod rarity-at-level ((pentry ptable-entry) (lvl real))
+  (with-slots ((min-level pentry-min-level)
+               (peaks pentry-peaks)) pentry
+    (let ((rarity (pentry-rarity pentry)))
+      (cond
+        ((and min-level
+              (< lvl min-level))
+         ;; level is below the minimum level where this item occurs.
+         nil)
+        (t
+         (/ rarity
+            (cond
+              ((null peaks) 1)
+              (t
+               (apply #'max
+                      (mapcar (lambda (peak)
+                                (expt *pentry-rarity-decay-factor*
+                                      (- (abs (- lvl peak)))))
+                              peaks))))))))))
+
+
+
+(define-memo-function probabilities-at-level (entries level
+                                                      &key cumulative? flat?
+                                                      sort?)
+  (cond
+    ((null entries)
+     nil)
+    (t
+     (let ((entries (mapcar (lambda (e) (cons (rarity-at-level e level) e))
+                            entries)))
+       (setf entries (remove nil entries :key #'car))
+       (let ((highest-rarity (apply #'max (mapcar #'car entries))))
+         ;; Convert rarities into frequencies.
+         (setf entries (mapcar (d-lambda (rarity . item)
+                                    (cons (/ highest-rarity rarity)
+                                          item))
+                               entries))
+         ;; Turn frequencies into probabilities (0-1). The sum of all the
+         ;; probabilities in the ptable is guaranteed to be 1.
+         (setq entries
+               (iterate
+                (with freq-sum = (coerce (apply #'+ (mapcar #'car entries))
+                                         'double-float))
+                (for (freq . item) in entries)
+                (cond
+                  ((and flat?
+                        (symbol->ptable item))
+                   ;; This entry refers to another ptable. The `flat?' option
+                   ;; is set, so expand the ptable inline. Multiply each
+                   ;; probability in the inline table by the probability for
+                   ;; the current entry.
+                   (appending (mapcar (d-lambda (p . e)
+                                           (cons (* p (/ freq freq-sum)) e))
+                                      (probabilities-at-level
+                                       (ptable-entries (symbol->ptable item))
+                                       level :cumulative? nil :flat? t))))
+                  (t
+                   (collect (cons (/ freq freq-sum)
+                                  item))))))
+         ;; If duplicate entries exist, combine their probabilities together.
+         (setq entries
+               (iterate
+                (with new-entries = nil)
+                (for (prob . entry) in entries)
+                (if-let (pos (position-if #'pentries-equal? new-entries
+                                          :key #'cdr))
+                        (incf (car (nth pos new-entries)) prob)
+                        ;; else
+                        (push (cons prob . entry) new-entries))
+                (finally
+                 (return new-entries))))
+         (if sort?
+             (setq entries (sort entries #'> :key #'car)))
+         (cond
+           (cumulative?
+            (iterate
+             (with cum-prob = 0d0)
+             (for (prob . entry) in entries)
+             (incf cum-prob prob)
+             (collect (cons cum-prob entry))))
+           (t
+            entries)))))))
+
+
+(defmethod ptable-probabilities ((tbl ptable) &key level cumulative? flat?)
+  (probabilities-at-level (ptable-entries tbl)
+                          level :cumulative? cumulative? :flat? flat?))
+
+
+;;;; <<External functions>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmethod random-entry ((tbl ptable) &optional level)
+  (let ((probs (ptable-probabilities tbl :level level :cumulative? t)))
+    (cond
+      ((null probs)
+       (error "choosing from empty ptable ~S" tbl))
+      (t
+       (iterate
+         (with p = (random 1.0d0))
+         (for (cum-prob . entry) in probs)
+         (when (<= p cum-prob)
+           (let ((item (pentry-item entry)))
+             (if-let (tbl2 (symbol->ptable item))
+                     (return (ptable-choose tbl2 level))
+                     ;; else
+                     (return (values item (pentry-choose-count
+                                           (pentry-count entry)))))))
+         (finally
+          (error "")))))))
+
+
+(defun pentry-choose-count (cnt)
+  (typecase cnt
+    (real cnt)
+    (null 1)
+    (list (rand-between (nth 0 cnt) (nth 1 cnt)))
+    (symbol (if (fboundp cnt)
+                (funcall cnt)
+                (error "")))
+    (otherwise (error ""))))
+
+
+
+;;;; <<Ptabled classes>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defclass ptabled-class ()
+  ((ptable-entries :initform nil :initarg :ptable-entries
+                   :documentation "List of PTABLE-ENTRIES. Each PTABLE-ENTRY
+is a list of the form (PTABLE-SYM FREQ [(CLAUSE) (CLAUSE)...]).
+In fact this list will always be embedded inside a further list, because
+of the way class options are stored.")))
+
+
+(defmethod initialize-instance :after ((tc ptabled-class)
+                                       &key &allow-other-keys)
+  ;; Get rid of the list surrounding the slot's contents.
+  (iterate
+    (for (ptable-sym . entry-body) in (all-ptable-entries tc))
+    (when ptable-sym
+      (format *error-output* "~&ptable ~S += ~S~%"
+              ptable-sym (class-name tc))
+      (ptable-replace-entry (symbol->ptable ptable-sym :make? t)
+                            (apply #'make-instance 'ptable-entry
+                                   :item (class-name tc)
+                                   entry-body)))))
+
+
+(defun ptabled-class? (c)
+  (typep c 'ptabled-class))
+
+
+(defgeneric* all-ptable-entries (x)
+  (:method ((p standard-object)) (all-ptable-entries (class-of p)))
+  (:method ((p standard-class))
+    (error "all-ptable-entries: class ~S is not of type ~S"
+           p (find-class 'ptabled-class)))
+  (:method ((p symbol))
+    (typecase p
+      (null (error "Illegal ptabled class: NIL"))
+      (otherwise (all-ptable-entries (find-class p t)))))
+  (:method ((pclass ptabled-class))
+    (ensure-finalized pclass)
+    (iterate
+      (with entries = nil)
+      (for c in (class-precedence-list pclass))
+      (when (ptabled-class? c)
+        (iterate
+          (for entry in (ptable-entries c))
+          ;; Only inherit entry if not overridden by a subclass
+          (unless (assoc (car entry) entries)
+            (push entry entries))))
+      (finally
+       (return entries)))))
+
+
+(defparameter animals
+  (make-instance 'ptable
+               :name :tbl-animals
+               :entries '((:item :squirrel :count 2 :rarity 5
+                           :min-level 1)
+                          (:item :hyena :count 1 :rarity :common
+                           :min-level 2 :peaks (5))
+                          (:item :fox :count 1 :rarity :uncommon
+                           :peaks (8))
+                          (:item :badger :count 1 :rarity :common))))
+
+
+;;;; ptable.lisp ends here  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;