Commits

Paul Sexton committed 1d0de22

It is now possible to specify that a particular ptabled-class does not
inherit ptable-entries from ancestors, via the boolean class option
:ptable-entries-inherited?.

We now keep a record of the name of every ptabled-class that is created.

New function: process-all-ptabled-classes. Scan all ptabled-classes and
re-process their ptable-entries.

Added explanation of ptabled-classes to the end of the README.

  • Participants
  • Parent commits aaf278d

Comments (0)

Files changed (2)

 
 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.
+to insert entries for themselves into ptables (see later for more details).
 
     :::lisp
     (define-ptable :tbl-foo
 * a series of 1 or more peak levels. When these are present, the entry's rarity
 will be scaled so that it is equal to the given rarity when the level is equal
 to one of the peaks, and becomes more rare as the level moves away from a peak.
+
+## The mixin class `ptabled-class`
+
+If classes are defined whose metaclass is `ptabled-class`, those classes may
+specify two class options:
+
+* `(:ptable-entries ( ENTRY* ))` -- where each ENTRY follows the format of a
+  ptable-entry (see above), except that instead of VALUE, a PTABLE-SYMBOL is
+  substituted.
+* `(:ptable-entries-inherited? BOOLEAN)` -- where BOOLEAN is t (default) or
+  nil.
+
+Each such class will, upon class definition or redefinition, have its name
+included as a value in each of the ptables listed in `:ptable-entries`.
+
+The class will also inherit the `:ptable-entries` of its ancestor classes,
+except where its own entries contradict earlier entries. To override this
+behaviour and force the class to only be included in those ptables that are
+explicitly listed in its own `:ptable-entries` slot, set
+`:ptable-entries-inherited?` to NIL.
    #:ptable-replace-entry
    #:ptable-contents
    #:ptabled-class
-   #:ptabled-class?))
+   #:ptabled-class?
+   #:process-all-ptabled-classes))
 
 (in-package :ptable)
 
       (+ min (funcall random-function (abs (1+ (- max min)))))))
 
 
+(defun all-subclasses (c &optional test)
+  "Return a list of the class C and all its direct and indrect subclasses.
+If TEST is supplied, it must be a function taking one argument -- a class
+instance -- and it must return non-nil if the class should be included in
+the returned list."
+  (typecase c
+    (null nil)
+    (symbol (all-subclasses (find-class c) test))
+    (class
+     (if (or (null test) (funcall test c))
+         (cons c (all-subclasses (class-direct-subclasses c) test))
+         (all-subclasses (class-direct-subclasses c) test)))
+    (otherwise (append (all-subclasses (first c) test)
+                       (all-subclasses (rest c) test)))))
+
+
+(defun remove-outer-parens (lst)
+  ;; If the value is of the form ((ENTRY ENTRY ...)) rather
+  ;; than (ENTRY ENTRY ...), remove the outer parentheses
+  (cond
+    ((equal lst '(nil))
+     nil)
+    ((and lst
+          (listp lst)
+          (= 1 (length lst))
+          (listp (first lst))
+          (first (first lst))
+          (listp (first (first lst))))
+     (first lst))
+    (t
+     lst)))
+
+
 ;;;; <<Declarations>> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
 (defgeneric pentry-rarity (pentry))
 (defgeneric ptable-add-entry (ptable entry))
 (defgeneric ptable-replace-entry (ptable entry))
-(defgeneric rarity-at-level (pentry level))
+(defgeneric rarity-at-level (pentry level)
+  (:documentation
+     "Calculate PENTRY's rarity adjusted for level LEVEL.
+Returns a number, or NIL if the item cannot occur (is infinitely rare) at
+that level."))
 (defgeneric ptable-probabilities (ptable &key level cumulative? flat? sort?))
 (defgeneric random-entry (ptable &optional level))
+(defgeneric process-ptable-entries-for-class (c))
 
 
 (defvar *ptables* (make-hash-table :test #'equal))
+(defvar *ptabled-class-names* nil)
 
 
 (defparameter *ptable-rarities*
 ;;;; <<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))
 
                    :documentation "List of PTABLE-ENTRIES. Each PTABLE-ENTRY
 is a list of the form (PTABLE-SYM RARITY [other ptable-entry args...]).
 In fact this list will always be embedded inside a further list, because
-of the way class options are stored.")))
+of the way class options are stored.")
+   (ptable-entries-inherited? :initform t
+                              :initarg :ptable-entries-inherited?
+                              :documentation
+                              "By default, each ptabled class also inherits
+the ptable entries of its ancestors. In other words, its `ptable-entries'
+slot ADDS TO the sum of all inherited ptable-entries slots. Setting
+`ptable-entries-inherited?' to nil overrides this behaviour, so that
+the class will only have the ptable entries explicitly specified
+in its class definition.")))
+
+
+(defmethod initialize-instance :after ((tc ptabled-class)
+                                       &key
+                                       &allow-other-keys)
+  (setf (slot-value tc 'ptable-entries-inherited?)
+        (remove-outer-parens
+         (slot-value tc 'ptable-entries-inherited?)))
+  (pushnew (class-name tc) *ptabled-class-names*)
+  (process-ptable-entries-for-class tc))
+
+
+(defmethod reinitialize-instance :after ((tc ptabled-class)
+                                       &key
+                                       &allow-other-keys)
+  (setf (slot-value tc 'ptable-entries-inherited?)
+        (remove-outer-parens
+         (slot-value tc 'ptable-entries-inherited?)))
+  (pushnew (class-name tc) *ptabled-class-names*)
+  (process-ptable-entries-for-class tc))
 
 
 (defmethod validate-superclass ((class ptabled-class)
 
 (defmethod process-ptable-entries-for-class ((tc ptabled-class))
   (iterate
-    (for (ptable-sym . entry-body) in (ptable-entries tc :inherited? t))
+    (for (ptable-sym . entry-body)
+         :in (ptable-entries
+              tc :inherited? (remove-outer-parens
+                              (slot-value tc 'ptable-entries-inherited?))))
     (when ptable-sym
       (when (or (numberp (car entry-body))
                 (assoc (car entry-body) *ptable-rarities*))
                                    entry-body)))))
 
 
-(defmethod initialize-instance :after ((tc ptabled-class)
-                                       &key
-                                       &allow-other-keys)
-  (process-ptable-entries-for-class tc))
-
-
-(defmethod reinitialize-instance :after ((tc ptabled-class)
-                                       &key
-                                       &allow-other-keys)
-  (process-ptable-entries-for-class tc))
+(defun process-all-ptabled-classes ()
+  (dolist (classname *ptabled-class-names*)
+    (let ((c (find-class classname nil)))
+      (when (ptabled-class? c)
+        (format *debug-io* "Processing ptabled-class ~S...~%" classname)
+        (process-ptable-entries-for-class c)))))
 
 
 (defun* (ptabled-class? -> boolean) (c)
 
 
 (defgeneric ptable-entries (c &key &allow-other-keys)
-  (:method ((pclass ptabled-class) &key (inherited? nil))
+  (:method ((pclass ptabled-class)
+            &key (inherited?
+                  (remove-outer-parens
+                   (slot-value pclass 'ptable-entries-inherited?))))
     (cond
       ((not inherited?)
-       (let ((entries (slot-value pclass '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)))
+       (remove-outer-parens (slot-value pclass 'ptable-entries)))
       (t
        (ensure-finalized pclass)
        (iterate
          (for c in (class-precedence-list pclass))
          (when (ptabled-class? c)
            (iterate
-             (for entry in (ptable-entries c))
+             (for entry in (remove-outer-parens
+                            (slot-value c 'ptable-entries)))
+             (unless entry (next-iteration))
              ;; Only inherit entry if not overridden by a subclass
              (unless (assoc (car entry) entries)
                (push entry entries))))