indices.lisp

Revision 3950, 19.0 kB (checked in by hans, 2 months ago)
Make it possible to restore datastores when packages have been deleted which are referenced by objects in the store.
Property svn:eol-style set to `native` Property svn:keywords set to `author date id revision`

Line
1	;;; XXX protokoll erweitern, das es auch eine funktion gibt, die die
2	;;; keys aus der klasse extrahiert, dann koennte man viel
3	;;; zusammenfaktorn
4
5	(in-package :bknr.indices)
6
7	;;;;;;;;;;;;;;;;;;;;
8	;;; Slot-bound index
9
10	;;; A slot-bound index is based on a hash-table. Objects are added to
11	;;; the hash-table using the slot-value of the specified slot as key.
12
13	(defclass slot-index ()
14	((hash-table :initarg :hash-table :accessor slot-index-hash-table
15	:documentation "The internal hash table used to index
16	objects.")
17	(slot-name :initarg :slot-name :reader slot-index-slot-name
18	:documentation "The value of the slot with name
19	SLOT-NAME is used as a key to the internal hash-table.")
20	(index-nil :initarg :index-nil :reader slot-index-index-nil
21	:initform nil
22	:documentation "If T, NIL is used as a valid slot value, else slots with NIL value are treated as unbound slots.")))
23
24	(defmethod initialize-instance :after ((index slot-index) &key (test #'eql) slot-name slots index-nil)
25	(unless slots
26	(setf slots (list slot-name)))
27	(unless (= (length slots) 1)
28	(error "Exactly one slot name in :SLOTS initarg required to create a SLOT-INDEX"))
29	(with-slots (hash-table slot-name) index
30	(setf hash-table (make-hash-table :test test #+sbcl #+sbcl :synchronized t)
31	slot-name (first slots)
32	(slot-value index 'index-nil) index-nil)))
33
34	(defmethod print-object ((object slot-index) stream)
35	(print-unreadable-object (object stream :type t :identity t)
36	(format stream "SLOT: ~S SIZE: ~D"
37	(slot-index-slot-name object)
38	(hash-table-count (slot-index-hash-table object)))))
39
40	(defmethod index-get ((index slot-index) key)
41	(gethash key (slot-index-hash-table index)))
42
43	(defmethod index-remove :around ((index slot-index) object)
44	(let ((slot-name (slot-index-slot-name index)))
45	(if (slot-boundp object slot-name)
46	(call-next-method)
47	(ignore-errors ;; guard against access to unbound slots in print method
48	(warn "Ignoring request to remove object ~A with unbound slot ~A."
49	object slot-name)))))
50
51	(defmethod index-remove ((index slot-index) object)
52	(remhash (slot-value object (slot-index-slot-name index)) (slot-index-hash-table index)))
53
54	(defmethod index-keys ((index slot-index))
55	(loop for key being the hash-keys of (slot-index-hash-table index)
56	collect key))
57
58	(defmethod index-values ((index slot-index))
59	(loop for value being the hash-values of (slot-index-hash-table index)
60	collect value))
61
62	(defmethod index-mapvalues ((index slot-index) fun)
63	(maphash (lambda (key val) (declare (ignore key)) (funcall fun val))
64	(slot-index-hash-table index)))
65
66	(defmethod index-clear ((index slot-index))
67	(with-slots (hash-table) index
68	(setf hash-table (make-hash-table :test (hash-table-test hash-table) #+sbcl #+sbcl :synchronized t))))
69
70	(defmethod index-reinitialize ((new-index slot-index)
71	(old-index slot-index))
72	"Reinitialize the slot-bound index from the old index by copying the
73	internal hash-table if the hash-table test is the same, or by
74	iterating over the values of the old-table and reentering them into
75	the new hash-table."
76	(let ((new-hash (slot-index-hash-table new-index))
77	(old-hash (slot-index-hash-table old-index)))
78	(if (eql (hash-table-test new-hash)
79	(hash-table-test old-hash))
80	(setf (slot-index-hash-table new-index)
81	old-hash)
82	(loop for key being the hash-keys of old-hash using (hash-value value)
83	do (setf (gethash key new-hash) value)))
84	new-index))
85
86	(defclass unique-index (slot-index)
87	())
88
89	(defmethod index-add ((index unique-index) object)
90	"Add an object using the value of the specified slot as key. When
91	the hash-table entry already contains a value, an error is signalled."
92	(unless (slot-boundp object (slot-index-slot-name index))
93	(return-from index-add))
94	(let* ((key (slot-value object (slot-index-slot-name index)))
95	(hash-table (slot-index-hash-table index)))
96	(when (and (not (slot-index-index-nil index))
97	(null key))
98	(return-from index-add))
99	(multiple-value-bind (value presentp)
100	(gethash key hash-table)
101	(when (and presentp
102	(not (eql value object)))
103	(error (make-condition 'index-existing-error
104	:index index :key key :value value)))
105	(setf (gethash key hash-table) object))))
106
107
108	(defclass string-unique-index (unique-index)
109	())
110
111	(defmethod initialize-instance :after ((index string-unique-index) &key (test #'equal))
112	(with-slots (hash-table) index
113	(setf hash-table (make-hash-table :test test #+sbcl #+sbcl :synchronized t))))
114
115	(defmethod index-add :around ((index string-unique-index) object)
116	(unless (slot-boundp object (slot-index-slot-name index))
117	(return-from index-add))
118	(let* ((key (slot-value object (slot-index-slot-name index))))
119	(unless (and (not (slot-index-index-nil index))
120	(string-equal key ""))
121	(call-next-method))))
122
123
124	;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125	;;; Slot-bound keyword index
126
127	;;; A slot-bound index storing multiple objects under one key.
128
129	(defclass hash-index (slot-index)
130	())
131
132	(defmethod index-add ((index hash-index) object)
133	(unless (slot-boundp object (slot-index-slot-name index))
134	(return-from index-add))
135	(let ((key (slot-value object (slot-index-slot-name index)))
136	(hash-table (slot-index-hash-table index)))
137	(when (and (not (slot-index-index-nil index))
138	(null key))
139	(return-from index-add))
140	(if (nth-value 1 (gethash key hash-table))
141	(push object (gethash key hash-table))
142	(setf (gethash key hash-table) (list object)))))
143
144	(defmethod index-remove ((index hash-index) object)
145	(let ((key (slot-value object (slot-index-slot-name index)))
146	(hash-table (slot-index-hash-table index)))
147	(let ((new-value (delete-first object (gethash key hash-table))))
148	(if (null new-value)
149	(remhash key hash-table)
150	(setf (gethash key hash-table) new-value)))))
151
152	(defmethod index-values ((index hash-index))
153	(loop for value being the hash-values of (slot-index-hash-table index)
154	appending value))
155
156	(defmethod index-mapvalues ((index hash-index) fun)
157	(maphash (lambda (key val) (declare (ignore key))
158	(dolist (obj val) (funcall fun obj)))
159	(slot-index-hash-table index)))
160
161	;;; Index objects by their class
162
163	(defclass class-index (hash-index)
164	((index-superclasses :initarg :index-superclasses :initform nil
165	:reader class-index-index-superclasses)))
166
167	(defmethod initialize-instance :after ((index class-index) &key index-superclasses)
168	(setf (slot-value index 'index-superclasses)
169	index-superclasses))
170
171	(defmethod index-add ((index class-index) object)
172	(labels ((index-object (object class)
173	(let ((key (class-name class))
174	(hash-table (slot-index-hash-table index)))
175	(if (nth-value 1 (gethash key hash-table))
176	(push object (gethash key hash-table))
177	(setf (gethash key hash-table) (list object))))))
178
179	(if (class-index-index-superclasses index)
180	(dolist (class (cons (class-of object)
181	(class-all-indexed-superclasses (class-of object))))
182	(index-object object class))
183	(index-object object (class-of object)))))
184
185	(defmethod index-remove ((index class-index) object)
186	(flet ((remove-object (object class)
187	(let ((key (class-name class))
188	(hash-table (slot-index-hash-table index)))
189	(let ((new-value (delete-first object (gethash key hash-table))))
190	(if (null new-value)
191	(remhash key hash-table)
192	(setf (gethash key hash-table) new-value))))))
193	(if (class-index-index-superclasses index)
194	(dolist (class (cons (class-of object)
195	(class-all-indexed-superclasses (class-of object))))
196	(remove-object object class))
197	(remove-object object (class-of object)))))
198
199	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
200	;;; Slot-bound keyword list index
201
202	;;; A keyword index, where the slot-value is a list of keys.
203
204	(defclass hash-list-index (slot-index)
205	())
206
207	(defmethod index-add ((index hash-list-index) object)
208	(unless (slot-boundp object (slot-index-slot-name index))
209	(return-from index-add))
210	(let ((keys (slot-value object (slot-index-slot-name index)))
211	(hash-table (slot-index-hash-table index)))
212	(dolist (key keys)
213	(if (nth-value 1 (gethash key hash-table))
214	(push object (gethash key hash-table))
215	(setf (gethash key hash-table) (list object))))))
216
217	(defmethod index-remove ((index hash-list-index) object)
218	(let ((keys (slot-value object (slot-index-slot-name index)))
219	(hash-table (slot-index-hash-table index)))
220	(dolist (key keys)
221	(let ((new-value (delete-first object (gethash key hash-table))))
222	(if (null new-value)
223	(remhash key hash-table)
224	(setf (gethash key hash-table) new-value))))))
225
226	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
227	;;; Multiple-slots array index
228
229	(defclass array-index ()
230	((slot-names :initarg :slot-names :accessor array-index-slot-names
231	:initform nil)
232	(array :initarg :array :accessor array-index-array)))
233
234	(defmethod initialize-instance :after ((index array-index) &key slots dimensions)
235	(setf (array-index-array index) (make-array dimensions :initial-element nil)
236	(array-index-slot-names index) slots))
237
238	(defmethod print-object ((object array-index) stream)
239	(print-unreadable-object (object stream :type t :identity t)
240	(format stream "SLOTS: ~S (~S)"
241	(array-index-slot-names object)
242	(array-dimensions (array-index-array object)))))
243
244	(defmethod index-add ((index array-index) object)
245	(let* ((slot-values
246	(mapcar #'(lambda (slot-name)
247	;; return when not all slots are set
248	;;
249	;; - 18.10.04 not needed because of
250	;; make-instance around method
251	;;
252	;; - 19.10.04 in fact this is needed because
253	;; when adding a class index, the existing
254	;; instances are not reinitailized using
255	;; make-instnace, so we have to catch this...
256	(unless (slot-boundp object slot-name)
257	(return-from index-add nil))
258	(slot-value object slot-name))
259	(array-index-slot-names index)))
260	(array (array-index-array index))
261	(dimensions (array-dimensions array)))
262	(loop for slot-value in slot-values
263	for dimension in dimensions
264	when (>= slot-value dimension)
265	do (error "Could not add ~a to array-index ~a because the coordinates ~a are out of bound." object index slot-values))
266	(let ((value (apply #'aref array slot-values)))
267	(when (and value
268	(not (eql value object)))
269	(error (make-condition 'index-existing-error
270	:index index :key slot-values :value value))))
271	(setf (apply #'aref array slot-values)
272	object)))
273
274	(defmethod index-get ((index array-index) coords)
275	(apply #'aref (array-index-array index) coords))
276
277	(defmethod index-remove ((index array-index) object)
278	(let* ((slot-values (mapcar #'(lambda (slot-name)
279	;;; return when not all slots are set
280	(unless (slot-boundp object slot-name)
281	(return-from index-remove nil))
282	(slot-value object slot-name))
283	(array-index-slot-names index)))
284	(array (array-index-array index))
285	(dimensions (array-dimensions array)))
286	(loop for slot-value in slot-values
287	for dimension in dimensions
288	when (>= slot-value dimension)
289	do (error "Could not remove ~a from array-index ~a because the coordinates ~a are out of bound." object index slot-values))
290	(setf (apply #'aref array slot-values) nil)))
291
292	(defmethod index-keys ((index array-index))
293	(error "An ARRAY-INDEX has no keys."))
294
295	(defmethod index-values ((index array-index))
296	(error "An ARRAY-INDEX cannot enumerate its values."))
297
298	(defmethod index-mapvalues ((index array-index) (fun function))
299	(error "An ARRAY-INDEX cannot enumerate its values."))
300
301	(defmethod index-reinitialize ((new-index array-index) (old-index array-index))
302	(when (equal (array-dimensions (array-index-array new-index))
303	(array-dimensions (array-index-array old-index)))
304	(setf (array-index-array new-index)
305	(array-index-array old-index))
306	new-index))
307
308	(defmethod index-clear ((index array-index))
309	(with-slots (array) index
310	(setf array (make-array (array-dimensions array) :initial-element nil))))
311
312	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313	;;; Ordered skip list index
314
315	(defclass skip-list-index ()
316	((skip-list :initarg :skip-list
317	:accessor skip-list-index-skip-list)
318	(slot-name :initarg :slot-name
319	:accessor skip-list-index-slot-name)
320	(index-nil :initarg :index-nil :initform nil
321	:accessor skip-list-index-index-nil)))
322
323	(defmethod initialize-instance :after ((index skip-list-index) &key slots index-nil)
324	(unless (<= (length slots) 1)
325	(error "Can not create slot-index with more than one slot."))
326	(with-slots (skip-list slot-name) index
327	(setf skip-list (make-instance 'skip-list)
328	slot-name (first slots)
329	(slot-value index 'index-nil) index-nil)))
330
331	(defmethod print-object ((object skip-list-index) stream)
332	(print-unreadable-object (object stream :type t :identity t)
333	(format stream "SLOT: ~S SIZE: ~D"
334	(skip-list-index-slot-name object)
335	(skip-list-length (skip-list-index-skip-list object)))))
336
337	(defmethod index-add ((index skip-list-index) object)
338	"Add an object using the value of the specified slot as key. When
339	the hash-table entry already contains a value, an error is thrown."
340	(unless (slot-boundp object (skip-list-index-slot-name index))
341	(return-from index-add))
342	(let* ((key (slot-value object (skip-list-index-slot-name index)))
343	(skip-list (skip-list-index-skip-list index)))
344	(when (and (not (skip-list-index-index-nil index))
345	(null key))
346	(return-from index-add))
347	(let ((value (skip-list-get key skip-list)))
348	(when (and value
349	(not (eql value object)))
350	(error (make-condition 'index-existing-error
351	:index index :key key :value value)))
352	(setf (skip-list-get key skip-list) object))))
353
354	(defmethod index-get ((index skip-list-index) key)
355	(skip-list-get key (skip-list-index-skip-list index)))
356
357	(defmethod index-remove ((index skip-list-index) object)
358	(skip-list-delete (slot-value object (skip-list-index-slot-name index))
359	(skip-list-index-skip-list index)))
360
361	(defmethod index-keys ((index skip-list-index))
362	(let ((keys))
363	(map-skip-list #'(lambda (key val) (declare (ignore val))
364	(push key keys))
365	(skip-list-index-skip-list index))
366	(nreverse keys)))
367
368	(defmethod index-values ((index skip-list-index))
369	(let ((vals))
370	(map-skip-list #'(lambda (key val) (declare (ignore key))
371	(push val vals))
372	(skip-list-index-skip-list index))
373	(nreverse vals)))
374
375	(defmethod cursor-next ((slc skip-list-cursor) &optional eoc)
376	(declare (ignore eoc))
377	(sl-cursor-next slc))
378
379	(defmethod cursor-prev ((slc skip-list-cursor) &optional eoc)
380	(declare (ignore eoc))
381	(sl-cursor-prev slc))
382
383	(defmethod index-values-cursor ((index skip-list-index))
384	(skip-list-values-cursor (skip-list-index-skip-list index)))
385
386	(defmethod index-keys-cursor ((index skip-list-index))
387	(skip-list-keys-cursor (skip-list-index-skip-list index)))
388
389	(defmethod index-mapvalues ((index skip-list-index) fun)
390	(map-skip-list #'(lambda (key val) (declare (ignore key))
391	(funcall fun val))
392	(skip-list-index-skip-list index)))
393
394	(defmethod index-clear ((index skip-list-index))
395	(with-slots (skip-list) index
396	(setf skip-list (make-instance 'skip-list))))
397
398	(defmethod index-reinitialize ((new-index skip-list-index)
399	(old-index skip-list-index))
400	"Reinitialize the slot-bound index from the old index by copying the
401	internal skip-list if the skip-list order function is the same, or by
402	iterating over the values of the old-list and reentering them into
403	the new skip-list."
404	(let ((new-list (skip-list-index-skip-list new-index))
405	(old-list (skip-list-index-skip-list old-index)))
406	(setf (skip-list-index-skip-list new-list) old-list)
407	new-index))
408
409	;;;;;;;;;;;;;;;;;;;;;;;;;
410	;;; class skip list index
411
412	(defclass class-skip-index ()
413	((index-superclasses :initarg :index-superclasses :initform nil
414	:reader class-skip-index-index-superclasses)
415	(slot-name :initarg :slot-name
416	:accessor class-skip-index-slot-name)
417	(hash-table :accessor class-skip-index-hash-table)))
418
419	(defmethod initialize-instance :after ((index class-skip-index)
420	&key (test #'eql) slots index-superclasses)
421	(unless (<= (length slots) 1)
422	(error "Can not create slot-index with more than one slot."))
423	(with-slots (hash-table slot-name) index
424	(setf hash-table (make-hash-table :test test #+sbcl #+sbcl :synchronized t)
425	slot-name (first slots)
426	(slot-value index 'index-superclasses) index-superclasses)))
427
428	(defmethod index-add ((index class-skip-index) object)
429	(labels ((index-object (object class)
430	(let ((key (class-name class))
431	(hash-table (class-skip-index-hash-table index))
432	(id-key (slot-value object (class-skip-index-slot-name index))))
433	(multiple-value-bind (skip-list presentp)
434	(gethash key hash-table)
435	(if presentp
436	(setf (skip-list-get id-key skip-list) object)
437	(let ((skip-list
438	(setf (gethash key hash-table)
439	(make-instance 'skip-list))))
440	(setf (skip-list-get id-key skip-list) object)))))))
441
442	(if (class-skip-index-index-superclasses index)
443	(dolist (class (cons (class-of object)
444	(class-all-indexed-superclasses (class-of object))))
445	(index-object object class))
446	(index-object object (class-of object)))))
447
448	(defmethod index-remove ((index class-skip-index) object)
449	(flet ((remove-object (object class)
450	(let* ((key (class-name class))
451	(hash-table (class-skip-index-hash-table index))
452	(id-key (slot-value object (class-skip-index-slot-name index)))
453	(skip-list (gethash key hash-table)))
454	(when skip-list
455	(skip-list-remove id-key skip-list)))))
456	(if (class-skip-index-index-superclasses index)
457	(dolist (class (cons (class-of object)
458	(class-all-indexed-superclasses (class-of object))))
459	(remove-object object class))
460	(remove-object object (class-of object)))))
461
462	(defmethod index-get ((index class-skip-index) key)
463	(let* ((hash-table (class-skip-index-hash-table index))
464	(skip-list (gethash key hash-table)))
465	(when skip-list
466	(let ((res))
467	(map-skip-list #'(lambda (key val) (declare (ignore key))
468	(push val res))
469	skip-list)
470	(nreverse res)))))
471
472	(defun copy-skip-list (skip-list)
473	(let ((new-skip-list (make-instance 'skip-list)))
474	(map-skip-list #'(lambda (key val)
475	(setf (skip-list-get new-skip-list key) val))
476	skip-list)
477	new-skip-list))
478
479	(defmethod index-reinitialize ((new-index class-skip-index)
480	(old-index class-skip-index))
481	(let* ((new-hash (class-skip-index-hash-table new-index))
482	(old-hash (class-skip-index-hash-table old-index)))
483	(if (eql (hash-table-test old-hash)
484	(hash-table-test new-hash))
485	(setf (class-skip-index-hash-table new-index) old-hash)
486	(maphash #'(lambda (key value)
487	(setf (gethash key new-hash) value))
488	old-hash))
489	new-index))
490
491	(defmethod index-clear ((index class-skip-index))
492	(with-slots (hash-table) index
493	(setf hash-table (make-hash-table :test (hash-table-test hash-table) #+sbcl #+sbcl :synchronized t))))
494
495	(defmethod index-keys ((index class-skip-index))
496	(loop for key being the hash-keys of (class-skip-index-hash-table index)
497	collect key))
498
499	;;; XXX class-skip-index set 2 times for every store-object

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format