1 (in-package :lisp-on-lines
)
3 (define-layered-function description-of
(thing)
5 (find-description 't
)))
7 (defun description-print-name (description)
8 (description-class-name (class-of description
)))
10 (defun find-attribute (description attribute-name
)
11 (when (slot-exists-p description attribute-name
)
12 (slot-value description attribute-name
)))
15 (defun description-attributes (description)
17 #'slot-value-using-class
18 (class-of 'description
)
20 (class-slots (class-of description
))))
24 (define-layered-function attributes
(description)
25 (:method
(description)
26 (let* ((active-attributes
27 (find-attribute description
'active-attributes
))
28 (attributes (when active-attributes
29 (attribute-value *object
* active-attributes
))))
31 (mapcar (lambda (spec)
40 (and (attribute-active-p attribute
)
41 (some #'layer-active-p
43 (slot-definition-layers
44 (attribute-effective-attribute-definition attribute
))))))
45 (description-attributes description
))))))
53 (defmacro define-description
(name &optional superdescriptions
&body options
)
54 (let ((description-name (defining-description name
)))
55 (destructuring-bind (&optional slots
&rest options
) options
56 (let ((description-layers (cdr (assoc :in-description options
))))
57 (if description-layers
58 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
61 :in description-layers
62 :collect
`(define-description
63 ,name
,superdescriptions
,slots
65 :in-layer
(defining-description layer
)
66 (remove :in-description options
:key
#'car
)))))
67 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
69 (defclass ,description-name
70 ,(append (mapcar #'defining-description
72 (unless (or (eq t name
)
73 (assoc :mixinp options
))
74 (list (defining-description t
))))
77 ,@(unless (assoc :metaclass options
)
78 '((:metaclass standard-description-class
))))
79 (initialize-descriptions)
80 (find-description ',name
)))))))