1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
(in-package #:metabang-dynamic-classes)
(defgeneric include-class-dependencies
(class-type dynamic-class class-list &rest parameters)
(:documentation ""))
(defgeneric existing-subclass (class-type class-list)
(:documentation ""))
;;; Support for dynamic classes based on the parameters for instantiation...
;;;
;;; Here is a quick history lesson: we've been doing this for shapes, since
;;; there was a massive amount of potential shape superclasses, and only a
;;; small subset were ever used for any given instance, and this was the
;;; cleanest and cutest approach...
(defvar *parameter-dynamic-class-table* nil)
(defun type->parameter-table (type)
(cdr (assoc type *parameter-dynamic-class-table*)))
(defun (setf type->parameter-table) (value type)
(let ((it (assoc type *parameter-dynamic-class-table*)))
(if it
(setf (cdr it) value)
(setf *parameter-dynamic-class-table*
(append *parameter-dynamic-class-table* (list (cons type value))))))
(values value))
(defun parameter->dynamic-class (table parameter)
(cdr (assoc parameter table)))
(defun (setf parameter->dynamic-class) (value table parameter)
(let ((it (assoc parameter table)))
(if it
(setf (cdr it) value)
(let ((temp (cdr table))
(insert (list (cons parameter value))))
(setf (cdr insert) temp
(cdr table) insert))))
(values value))
(defun table¶meter->dynamic-class (class-type parameter)
(parameter->dynamic-class (type->parameter-table class-type) parameter))
(defun add-parameter->dynamic-class (class-type
parameter &rest super-classes)
(let* ((current-table (or (type->parameter-table class-type)
(list (cons :remove :remove))))
(have-table? (not (eq (caar current-table) :remove))))
(dolist (super-class (ensure-list super-classes))
(let ((it (parameter->dynamic-class current-table parameter)))
(if it
(pushnew super-class it)
(setf (parameter->dynamic-class current-table parameter)
(list super-class)))))
(unless have-table?
(setf (type->parameter-table class-type) current-table)))
(values nil))
(defun add-dynamic-class-for-parameters (class-type dynamic-class
&rest parameters)
(dolist (parameter (ensure-list parameters))
(add-parameter->dynamic-class
class-type parameter dynamic-class)))
#+Later
(defun remove-parameter->dynamic-class (class-type parameter dynamic-class)
(let ((primary-table
(containers:item-at *parameter-dynamic-class-table* class-type)))
(when (and primary-table (containers:item-at primary-table parameter))
(setf (containers:item-at primary-table parameter)
(remove dynamic-class
(containers:item-at primary-table parameter))))))
(defun empty-add-parameter->dynamic-class (class-type)
(setf (type->parameter-table class-type) nil))
(defun empty-all-add-parameter->dynamic-class ()
(setf *parameter-dynamic-class-table* nil))
(defun dynamic-class-information ()
(loop for (type . data) in *parameter-dynamic-class-table* collect
(list type
(loop for (parameter . class) in data collect
(list parameter class)))))
(defmethod include-class-dependencies
((class-type (eql nil))
dynamic-class class-list &rest parameters)
(declare (ignore dynamic-class class-list parameters)))
(defmethod existing-subclass ((class-type (eql nil)) (class-list t))
(values nil))
(defun determine-dynamic-class (class-type dynamic-class &rest parameters)
(let ((class-list
(loop for parameter in parameters
for keyword? = t then (not keyword?)
when keyword? nconc
(loop for class in (table¶meter->dynamic-class
class-type parameter)
when (or (not dynamic-class)
(and dynamic-class
(not (subtypep class dynamic-class))))
collect class))))
(setf class-list
(apply #'include-class-dependencies
class-type dynamic-class class-list parameters))
(when (and dynamic-class (not (some (lambda (class-name)
(subtypep dynamic-class class-name))
class-list)))
(setf class-list (nconc (list dynamic-class) class-list)))
(setf class-list (delete-duplicates class-list))
(let ((it nil))
(cond ((setf it (existing-subclass class-type class-list))
it)
(t
(if (and (length-1-list-p class-list)
(find-class (first class-list) nil))
(first class-list)
(define-class nil class-list nil)))))))
|
