Commits

Paul Sexton committed b093518

Now it compiles!

  • Participants
  • Parent commits eea2571

Comments (0)

Files changed (2)

 up piecewise. A "ptabled-class" metaclass is also provided which allows classes
 to insert entries for themselves into ptables.
 
+## Rarity
+
+The Advanced Dungeons and Dragons Monster Manuals gave each monster a
+frequency that indicated how often it should be encountered.
+
+AD&D Frequency    Probability   PTable rarity
+Common            0.42          1.0
+Uncommon          0.27          1.5
+Rare              0.22          1.9
+Very rare         0.09          4.4
+
+It can be appreciated that "very rare" monsters were not terribly rare -- a
+dice roll would generate a very rare monster 9% of the time.
+
+The levelled lists used in the Elder Scrolls games do not specify probabilities
+or rarities for their contents. The only fact that is specified for each item
+in a levelled list is the minimum player level at which it may appear. Groups
+of items can be made relatively rare by putting them into a levelled list, then
+using that list as an item in another list.
+
 ## Levels and ptables
 
 Each entry can also contain information about how its rarity should vary as a
 
 (declaim (optimize (speed 0) (safety 3) (debug 3)))
 
+;;;; [[Utilities]]
+;;;; [[Declarations]]
 ;;;; [[Ptable class]]
 ;;;; [[Ptable entry class]]
 ;;;; [[Rarity and probability functions]]
 (in-package :ptable)
 
 
+;;;; <<Utilities>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defmacro d-lambda (d-lambda-list &body body)
+  "Like `lambda', but the argument list is a destructuring lambda list."
+  (with-gensyms (args)
+    `(lambda (,args) (destructuring-bind ,d-lambda-list ,args
+                  ,@body))))
+
+
+(defun* (rand-between -> integer) ((min integer) (max integer)
+                                   &key ((exclusive? boolean) nil)
+                                        (random-function #'random))
+  "Return a random integer between MIN and MAX. Include MIN and MAX in
+the range of possible return values, unless EXCLUSIVE is true.
+
+If RANDOM-FUNCTION is supplied, it must be a function that takes one argument
+and behaves like RANDOM, i.e. returns a random number between 0...N-1."
+  (if (> min max)
+      (psetf min max
+	     max min))
+  (if exclusive?
+      (+ min (1+ (funcall random-function (abs (- max min 1)))))
+      ;; else
+      (+ min (funcall random-function (abs (1+ (- max min)))))))
+
+
+;;;; <<Declarations>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 (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 ptable-probabilities (ptable &key level cumulative? flat? sort?))
 (defgeneric random-entry (ptable &optional level))
 
 
     (let ((tbl (symbol->ptable sym :make? t)))
       (iterate
         (for (item . body) in entries)
-        (ptable-replace-entry tbl entry))
+        (ptable-replace-entry tbl (append (list :item item) body)))
       (values sym tbl))))
 
 
 ;;;; <<Ptable class>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-(define-class ptable ()
-  (ptable-name nil :initarg :name)
-  (ptable-entries nil))
+(defclass ptable ()
+  ((ptable-name :initform nil :initarg :name :accessor ptable-name)
+   (ptable-entries :initform nil)))
 
 
 (defmethod print-object ((tbl ptable) strm)
             (ptable-name tbl)
             (length (ptable-entries tbl)))
     (dolist (pentry (ptable-entries tbl))
-      (format strm "~&  ~S" pentry))
-    (terpri strm)))
+      (format strm "~&  ~S" pentry))))
 
 
 ;; `entries', if supplied, is a list of argument-lists. Each argument-list will
 ;;;; <<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."))
+(defclass ptable-entry ()
+  ((pentry-item :initform nil :initarg :item :accessor pentry-item)
+   (pentry-count :initform 1 :initarg :count :accessor pentry-count)
+   (pentry-rarity :initform 1 :initarg :rarity)
+   (pentry-min-level :initform nil :initarg :min-level
+                     :accessor pentry-min-level)
+   (pentry-peaks :initform nil :type list :initarg :peaks
+                 :accessor pentry-peaks
+                 :documentation "List of levels where the item's commonness
+peaks. This can be a single number, or several numbers to provide multimodal
+distributions.")))
 
 
 (defmethod print-object ((pentry ptable-entry) strm)
     (typecase rarity
       (symbol (cdr (assoc rarity *ptable-rarities*)))
       (number rarity)
-      (otherwise (error "")))))
+      (otherwise (error "Unrecognised rarity `~S' in ptable-entry ~S"
+                        rarity pentry)))))
 
 
 (defmethod ptable-add-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)))
+(defmethod ptable-replace-entry ((tbl ptable) (entry list))
+  (ptable-replace-entry tbl (list-to-entry entry)))
 
 
-(defun list-to-entry ((entry list))
+(defun list-to-entry (entry)
   (cond
     ((atom entry)
      (error "Cannot make ptable-entry out of value `~S'" entry))
 
 
 
-(define-memo-function probabilities-at-level (entries level
-                                                      &key cumulative? flat?
-                                                      sort?)
+(defun probabilities-at-level (entries level
+                               &key cumulative? flat?
+                                    sort?)
   (cond
     ((null entries)
      nil)
        (let ((highest-rarity (apply #'max (mapcar #'car entries))))
          ;; Convert rarities into frequencies.
          (setf entries (mapcar (d-lambda (rarity . item)
-                                    (cons (/ highest-rarity 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))))))
+                 (with freq-sum = (coerce (apply #'+ (mapcar #'car entries))
+                                          'double-float))
+                 (for (freq . entry) in entries)
+                 (cond
+                   ((and flat?
+                         (symbol->ptable (pentry-item entry)))
+                    ;; 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
+                                                         (pentry-item entry)))
+                                        level :cumulative? nil :flat? t))))
+                   (t
+                    (collect (cons (/ freq freq-sum)
+                                   entry))))))
          ;; 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))))
+                 (with new-entries = nil)
+                 (for (prob . entry) in entries)
+                 (if-let (pos (position-if (lambda (e)
+                                             (pentries-equal? e entry))
+                                           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))))
+              (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?)
+(defmethod ptable-probabilities ((tbl ptable) &key level cumulative? flat?
+                                                   sort?)
   (probabilities-at-level (ptable-entries tbl)
-                          level :cumulative? cumulative? :flat? flat?))
+                          level :cumulative? cumulative? :flat? flat?
+                          :sort? sort?))
 
 
 ;;;; <<External functions>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          (when (<= p cum-prob)
            (let ((item (pentry-item entry)))
              (if-let (tbl2 (symbol->ptable item))
-                     (return (ptable-choose tbl2 level))
+                     (return (random-entry tbl2 level))
                      ;; else
                      (return (values item (pentry-choose-count
                                            (pentry-count entry)))))))
 ;;;; <<Ptabled classes>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
-(defclass ptabled-class ()
+(defclass ptabled-class (standard-class)
   ((ptable-entries :initform nil :initarg :ptable-entries
+                   :accessor 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 validate-superclass ((class ptabled-class)
+                                (superclass standard-class))
+  t)
+
+(defmethod validate-superclass ((class standard-class)
+                                (superclass ptabled-class))
+  ;; Perhaps should be nil?
+  t)
+
 
 (defmethod initialize-instance :after ((tc ptabled-class)
-                                       &key &allow-other-keys)
+                                       &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))
   (typep c 'ptabled-class))
 
 
+(defgeneric ptable-entries (c)
+  (:method ((c ptabled-class))
+    (let ((entries (slot-value c 'ptable-entries)))
+      ;; If the value is of the form ((ENTRY ENTRY ...)) rather
+      ;; than (ENTRY ENTRY ...), remove the outer parentheses
+      (if (and entries
+               (listp entries)
+               (= 1 (length entries))
+               (listp (first entries))
+               (first (first entries))
+               (listp (first (first entries))))
+          (first entries)
+          entries)))
+  (:method ((c null)) (error "Asked for ptable-entries of NIL"))
+  (:method ((tbl ptable)) (slot-value tbl 'ptable-entries))
+  (:method ((kwd symbol)) (if (symbol->ptable kwd)
+                              (ptable-entries (symbol->ptable kwd)))))
+
+
+(defmethod (setf ptable-entries) (value (tbl ptable))
+  (setf (slot-value tbl 'ptable-entries) value))
+
+
 (defgeneric* all-ptable-entries (x)
   (:method ((p standard-object)) (all-ptable-entries (class-of p)))
   (:method ((p standard-class))
                            :peaks (8))
                           (:item :badger :count 1 :rarity :common))))
 
+(define-ptable :tbl-plants
+  (:apple :rarity 3 :min-level 2)
+  (:pear :rarity 4 :min-level 4)
+  (:carrot :rarity :common)
+  (:tbl-trees :rarity 2)
+  (:banana :rarity 10 :peaks (4)))
+
+(define-ptable :tbl-trees
+  (:oak-tree :rarity 2 :peaks (3))
+  (:ash-tree :rarity 3)
+  (:spruce-tree :rarity 4 :min-level 2))
+
+(defclass furniture ()
+  ((name :initform nil :accessor name))
+  (:metaclass ptabled-class))
+
+(defclass chair (furniture)
+  ((name :initform "chair"))
+  (:ptable-entries ((:tbl-furniture :rarity :common)))
+  (:metaclass ptabled-class))
+
+
 
 ;;;; ptable.lisp ends here  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;