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) |
11 | (slot-value description attribute-name)) |
12 | |
13 | #+nil(mapcar (lambda (slotd) |
14 | (slot-value-using-class (class-of description) description slotd)) |
15 | (class-slots (class-of description))) |
e7c5f95a |
16 | (defun description-attributes (description) |
4358148e |
17 | (mapcar #'attribute-object (class-slots (class-of description)))) |
18 | |
19 | (define-layered-function attributes (description) |
20 | (:method (description) |
21 | (remove-if-not |
22 | (lambda (attribute) |
23 | (and (eq (class-of description) |
24 | (print (slot-value attribute 'description-class))) |
25 | (some #'layer-active-p |
26 | (mapcar #'find-layer |
27 | (slot-definition-layers |
28 | (attribute-effective-attribute-definition attribute)))))) |
29 | (description-attributes description)))) |
e7c5f95a |
30 | |
4358148e |
31 | |
32 | ;;; A handy macro. |
33 | (defmacro define-description (name &optional superdescriptions &body options) |
34 | (let ((description-name (defining-description name))) |
35 | (destructuring-bind (&optional slots &rest options) options |
36 | (let ((description-layers (cdr (assoc :in-description options)))) |
37 | (if description-layers |
38 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
39 | ,@(loop |
40 | :for layer |
41 | :in description-layers |
42 | :collect `(define-description |
43 | ,name ,superdescriptions ,slots |
44 | ,@(acons |
45 | :in-layer (defining-description layer) |
46 | (remove :in-description options :key #'car))))) |
47 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
48 | ; `(progn |
49 | (defclass ,description-name |
50 | ,(append (mapcar #'defining-description |
51 | superdescriptions) |
52 | (unless (or (eq t name) |
53 | (assoc :mixinp options)) |
54 | (list (defining-description t)))) |
55 | ,(if slots slots '()) |
56 | ,@options |
57 | ,@(unless (assoc :metaclass options) |
58 | '((:metaclass standard-description-class)))) |
f2ff8a16 |
59 | (initialize-descriptions) |
4358148e |
60 | (find-description ',name))))))) |
61 | |
62 | |
63 | |
64 | |
65 | |
66 | |
67 | |
68 | |
e7c5f95a |
69 | |
e7c5f95a |
70 | |
71 | |
72 | |
73 | |
74 | |
75 | |
76 | |
77 | |
78 | |
79 | |
80 | |