e7c5f95a |
1 | (in-package :lisp-on-lines) |
2 | |
4358148e |
3 | (define-layered-function description-of (thing) |
4 | (:method (thing) |
5 | (find-description 't))) |
e7c5f95a |
6 | |
4358148e |
7 | (defun description-print-name (description) |
8 | (description-class-name (class-of description))) |
e7c5f95a |
9 | |
4358148e |
10 | (defun find-attribute (description attribute-name) |
6de8d300 |
11 | (when (slot-exists-p description attribute-name) |
12 | (slot-value description attribute-name))) |
4358148e |
13 | |
4271ab0b |
14 | |
e7c5f95a |
15 | (defun description-attributes (description) |
4271ab0b |
16 | (mapcar (curry |
17 | #'slot-value-using-class |
18 | (class-of 'description) |
19 | description) |
20 | (class-slots (class-of description)))) |
21 | |
6de8d300 |
22 | |
4358148e |
23 | |
24 | (define-layered-function attributes (description) |
25 | (:method (description) |
6de8d300 |
26 | (let* ((active-attributes |
27 | (find-attribute description 'active-attributes)) |
28 | (attributes (when active-attributes |
29 | (attribute-value *object* active-attributes)))) |
30 | (if attributes |
31 | (mapcar (lambda (spec) |
32 | (find-attribute |
33 | description |
34 | (if (listp spec) |
35 | (car spec) |
36 | spec))) |
37 | attributes) |
38 | (remove-if-not |
39 | (lambda (attribute) |
40 | (and (attribute-active-p attribute) |
41 | (some #'layer-active-p |
42 | (mapcar #'find-layer |
43 | (slot-definition-layers |
44 | (attribute-effective-attribute-definition attribute)))))) |
45 | (description-attributes description)))))) |
46 | |
47 | |
48 | |
49 | |
e7c5f95a |
50 | |
4358148e |
51 | |
52 | ;;; A handy macro. |
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 |
4271ab0b |
58 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
59 | ,@(loop |
60 | :for layer |
61 | :in description-layers |
62 | :collect `(define-description |
63 | ,name ,superdescriptions ,slots |
64 | ,@(acons |
65 | :in-layer (defining-description layer) |
66 | (remove :in-description options :key #'car))))) |
4271ab0b |
67 | `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) |
4358148e |
68 | ; `(progn |
69 | (defclass ,description-name |
70 | ,(append (mapcar #'defining-description |
71 | superdescriptions) |
72 | (unless (or (eq t name) |
73 | (assoc :mixinp options)) |
74 | (list (defining-description t)))) |
75 | ,(if slots slots '()) |
76 | ,@options |
77 | ,@(unless (assoc :metaclass options) |
78 | '((:metaclass standard-description-class)))) |
f2ff8a16 |
79 | (initialize-descriptions) |
4358148e |
80 | (find-description ',name))))))) |
81 | |
82 | |
83 | |
84 | |
85 | |
86 | |
87 | |
88 | |
e7c5f95a |
89 | |
e7c5f95a |
90 | |
91 | |
92 | |
93 | |
94 | |
95 | |
96 | |
97 | |
98 | |
99 | |
100 | |