Properties are special now!
[clinton/lisp-on-lines.git] / src / description.lisp
1 (in-package :lisp-on-lines)
2
3 (define-layered-function description-of (thing)
4 (:method (thing)
5 (find-description 't)))
6
7 (defun description-print-name (description)
8 (description-class-name (class-of description)))
9
10 (defun find-attribute (description attribute-name)
11 (when (slot-exists-p description attribute-name)
12 (slot-value description attribute-name)))
13
14
15 (defun description-attributes (description)
16 (mapcar (curry
17 #'slot-value-using-class
18 (class-of 'description)
19 description)
20 (class-slots (class-of description))))
21
22
23
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))))
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
50
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
58 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
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)))))
67 `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
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))))
79 (initialize-descriptions)
80 (find-description ',name)))))))
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100