(defmacro define-ptable (sym &body body)

-- 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.

+- BODY :: consists of the forms (PTABLE-ENTRY) (PTABLE-ENTRY) ....

+PTABLE-ENTRY := ITEM ENTRY-ARGS...

+ | ITEM RARITY ENTRY-ARGS...

(let ((tbl (symbol->ptable sym :make? t)))

(for (item . body) in entries)

+ (when (or (numberp (car body))

+ (assoc (car body) *ptable-rarities*))

(ptable-replace-entry tbl (append (list :item item) body)))

-(defun symbol->ptable (sym &key (error? nil) (make? nil))

+(defun* (symbol->ptable -> (or null ptable)) ((sym symbol)

+ (null (error "There is no ptable named NIL"))

(symbol (or (gethash sym *ptables*)

(make? (make-instance 'ptable :name sym))

(ptable-replace-entry tbl (list-to-entry entry)))

-(defun~~ ~~list-to-entry ~~(entry~~)

+(defun* (list-to-entry -> ptable-entry) ((entry list))

(error "Cannot make ptable-entry out of value `~S'" entry))

-(defun probabilities-at-level (entries level

+(define-memo-function probabilities-at-level (entries level

+ "ENTRIES is a list of `ptable-entry' instances, usually taken from the

+ptable-entries slot of a `ptable' instance.

+Returns an alist of the form ((P . ENTRY)*), where P is the probability of

+choosing the associated entry. Any duplicate entries will be combined.

+If LEVEL is supplied, then any entries that contain level-related information

+such as a minimum level or peaks, will have their probabilities adjusted to take

+the supplied level into account.

+If CUMULATIVE? is non-nil, the probabilities will be cumulative, i.e. each will

+have the preceding probabilities added to it, and the final probability will

+If FLAT? is non-nil, any entries that refer to ptables will be expanded in

+place, i.e., replaced by the results of calling this function for that ptable,

+with the probabilities adjusted so they add up to whatever the probability for

+the original ptable entry would have been.

(let ((entries (mapcar (lambda (e) (cons (rarity-at-level e level) e))

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

- ;; Turn frequencies into probabilities (0-1). The sum of all the

- ;; probabilities in the ptable is guaranteed to be 1.

- (with freq-sum = (coerce (apply #'+ (mapcar #'car entries))

- (for (freq . entry) in entries)

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

- (appending (mapcar (d-lambda (p . e)

- (cons (* p (/ freq freq-sum)) e))

- (probabilities-at-level

- (ptable-entries (symbol->ptable

- level :cumulative? nil :flat? t))))

- (collect (cons (/ freq freq-sum)

- ;; If duplicate entries exist, combine their probabilities together.

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

- (push (cons prob entry) new-entries))

- (return new-entries))))

- (setq entries (sort entries #'> :key #'car)))

- (for (prob . entry) in entries)

- (collect (cons cum-prob entry))))

+ ;; Convert rarities into relative frequencies.

+ (setf entries (mapcar (d-lambda (rarity . item)

+ ;; Turn frequencies into probabilities (0-1). The sum of all the

+ ;; probabilities in the ptable is guaranteed to be 1.

+ (with freq-sum = (coerce (apply #'+ (mapcar #'car entries))

+ (for (freq . entry) in entries)

+ (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

+ (appending (mapcar (d-lambda (p . e)

+ (cons (* p (/ freq freq-sum)) e))

+ (probabilities-at-level

+ (ptable-entries (symbol->ptable

+ level :cumulative? nil :flat? t))))

+ (collect (cons (/ freq freq-sum)

+ ;; If duplicate entries exist, combine their probabilities together.

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

+ (push (cons prob entry) new-entries))

+ (return new-entries))))

+ (setq entries (sort entries #'> :key #'car)))

+ (for (prob . entry) in entries)

+ (collect (cons cum-prob entry))))

(defmethod ptable-probabilities ((tbl ptable) &key level cumulative? flat?

(let ((probs (ptable-probabilities tbl :level level :cumulative? t)))

- (error "~~c~~hoosing from empty ptable ~S" tbl))

+ (error "Choosing from empty ptable ~S" tbl))

(with p = (random 1.0d0))

(return (values item (pentry-choose-count

(pentry-count entry)))))))

+ (error "Probabilities of ptable ~S add up to < 1 " tbl)))))))

(defun pentry-choose-count (cnt)

(list (rand-between (nth 0 cnt) (nth 1 cnt)))

(symbol (if (fboundp cnt)

- (otherwise (error ""))))

+ (error "~S is not a valid pentry-count value" cnt)))

+ (otherwise (error "~S is not a valid pentry-count value" cnt))))

((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)~~...]).

+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.")))

(defmethod validate-superclass ((class ptabled-class)

(superclass standard-class))

(defmethod initialize-instance :after ((tc ptabled-class)

- ;; Get rid of the list surrounding the slot's contents.

- (for (ptable-sym . entry-body) in (~~all-~~ptable-entries tc))

+ (for (ptable-sym . entry-body) in (ptable-entries tc :inherited? t))

- (format *error-output* "~&ptable ~S += ~S~%"

- ptable-sym (class-name tc))

+ (when (or (numberp (car entry-body))

+ (assoc (car entry-body) *ptable-rarities*))

+ (push :rarity entry-body))

+ ;; (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

-(defun~~ ~~ptabled-class? (c)

+(defun* (ptabled-class? -> boolean) (c)

(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

- (listp (first entries))

- (first (first entries))

- (listp (first (first 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)))))

+(defgeneric ptable-entries (c &key &allow-other-keys)

+ (:method ((pclass ptabled-class) &key (inherited? nil))

+ (let ((entries (slot-value pclass 'ptable-entries)))

+ ;; If the value is of the form ((ENTRY ENTRY ...)) rather

+ ;; than (ENTRY ENTRY ...), remove the outer parentheses

+ (listp (first entries))

+ (first (first entries))

+ (listp (first (first entries))))

+ (ensure-finalized pclass)

+ (for c in (class-precedence-list pclass))

+ (when (ptabled-class? c)

+ (for entry in (ptable-entries c))

+ ;; Only inherit entry if not overridden by a subclass

+ (unless (assoc (car entry) entries)

+ (push entry entries))))

+ (:method ((p standard-class) &key)

+ (error "ptable-entries: class ~S is not of type ~S"

+ p (find-class 'ptabled-class)))

+ (:method ((c null) &key) (error "Asked for ptable-entries of NIL"))

+ (:method ((tbl ptable) &key) (slot-value tbl 'ptable-entries))

+ (:method ((p standard-object) &key) (ptable-entries (class-of p)))

+ (:method ((sym symbol) &key)

+ (ptable-entries (symbol->ptable sym)))

+ (ptable-entries (find-class sym nil)))

+ (error "Don't know how to get ptable-entries of `~S'" sym)))))

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

- (error "all-ptable-entries: class ~S is not of type ~S"

- p (find-class 'ptabled-class)))

- (null (error "Illegal ptabled class: NIL"))

- (otherwise (all-ptable-entries (find-class p t)))))

- (:method ((pclass ptabled-class))

- (ensure-finalized pclass)

- (for c in (class-precedence-list pclass))

- (when (ptabled-class? c)

- (for entry in (ptable-entries c))

- ;; Only inherit entry if not overridden by a subclass

- (unless (assoc (car entry) entries)

- (push entry entries))))

(:item :badger :count 1 :rarity :common))))

(define-ptable :tbl-plants

- (:apple ~~:rarity ~~3 :min-level 2)

+ (:apple 3 :min-level 2)

(:pear :rarity 4 :min-level 4)

(:carrot :rarity :common)

(:ptable-entries ((:tbl-furniture :rarity :common)))

(:metaclass ptabled-class))

+(defclass table (furniture)

+ ((name :initform "table"))

+ (:ptable-entries ((:tbl-furniture :uncommon)))

+ (:metaclass ptabled-class))

;;;; ptable.lisp ends here ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;