Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

datamodel_test.lisp

Last change on this file was 324, checked in by lgiessmann, 14 years ago
new-datamodel: fixed a bug in the datamodel-unit-test for "get-item-by-psi"
File size: 152.6 KB

Line
1	;;+-----------------------------------------------------------------------------
2	;;+ Isidorus
3	;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann
4	;;+
5	;;+ Isidorus is freely distributable under the LGPL license.
6	;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt.
7	;;+-----------------------------------------------------------------------------
8
9
10	(defpackage :datamodel-test
11	(:use
12	:common-lisp
13	:datamodel
14	:it.bese.FiveAM
15	:fixtures
16	:unittests-constants)
17	(:import-from :exceptions
18	duplicate-identifier-error
19	missing-argument-error
20	tm-reference-error
21	object-not-found-error
22	not-mergable-error)
23	(:import-from :constants
24	xml-string
25	xml-uri)
26	(:export :run-datamodel-tests
27	:datamodel-test
28	:test-VersionInfoC
29	:test-VersionedConstructC
30	:test-ItemIdentifierC
31	:test-PersistentIdC
32	:test-SubjectLocatorC
33	:test-TopicIdentificationC
34	:test-get-item-by-id
35	:test-get-item-by-item-identifier
36	:test-get-item-by-locator
37	:test-get-item-by-psi
38	:test-ReifiableConstructC
39	:test-OccurrenceC
40	:test-VariantC
41	:test-NameC
42	:test-TypableC
43	:test-ScopableC
44	:test-RoleC
45	:test-player
46	:test-TopicMapC
47	:test-delete-ItemIdentifierC
48	:test-delete-PersistentIdC
49	:test-delete-SubjectLocatorC
50	:test-delete-ReifiableConstructC
51	:test-delete-VariantC
52	:test-delete-NameC
53	:test-delete-OccurrenceC
54	:test-delete-TypableC
55	:test-delete-ScopableC
56	:test-delete-AssociationC
57	:test-delete-RoleC
58	:test-equivalent-PointerC
59	:test-equivalent-OccurrenceC
60	:test-equivalent-NameC
61	:test-equivalent-VariantC
62	:test-equivalent-RoleC
63	:test-equivalent-AssociationC
64	:test-equivalent-TopicC
65	:test-equivalent-TopicMapC
66	:test-class-p
67	:test-find-item-by-revision
68	:test-make-Unknown
69	:test-make-VersionedConstructC
70	:test-make-TopicIdentificationC
71	:test-make-PersistentIdC
72	:test-make-SubjectLocatorC
73	:test-make-ItemIdentifierC
74	:test-make-OccurrenceC
75	:test-make-NameC
76	:test-make-VariantC
77	:test-make-RoleC
78	:test-make-TopicMapC
79	:test-make-AssociationC
80	:test-make-TopicC
81	:test-find-oldest-construct
82	:test-move-referenced-constructs-ReifiableConstructC
83	:test-move-referenced-constructs-NameC
84	:test-merge-constructs-TopicC-1
85	:test-merge-constructs-TopicC-2
86	:test-merge-constructs-TopicC-3
87	:test-merge-constructs-TopicC-4
88	:test-merge-constructs-TopicC-5
89	:test-merge-constructs-TopicC-6
90	:test-merge-constructs-TopicC-7
91	:test-merge-constructs-TopicC-8
92	:test-merge-constructs-TopicC-9
93	:test-merge-constructs-TopicC-10
94	:test-merge-constructs-AssociationC))
95
96
97	(declaim (optimize (debug 3)))
98
99	(in-package :datamodel-test)
100
101	(def-suite datamodel-test
102	:description "tests various key functions of the datamodel")
103
104	(in-suite datamodel-test)
105
106	(defvar db-dir "data_base")
107
108	(test test-VersionInfoC ()
109	"Tests various functions of the VersionInfoC class."
110	(with-fixture with-empty-db (db-dir)
111	(let ((vi-1 (make-instance 'd::VersionInfoC
112	:start-revision 100
113	:end-revision 300))
114	(vi-2 (make-instance 'd::VersionInfoC
115	:start-revision 300))
116	(vc (make-instance 'd::VersionedConstructC)))
117	(is (= (d::start-revision vi-1) 100))
118	(is (= (d::end-revision vi-1) 300))
119	(is (= (d::start-revision vi-2) 300))
120	(is (= (d::end-revision vi-2) 0))
121	(setf (d::versioned-construct vi-1) vc))))
122
123
124	(test test-VersionedConstructC ()
125	"Tests various functions of the VersionedCoinstructC class."
126	(with-fixture with-empty-db (db-dir)
127	(let ((vc (make-instance 'd::VersionedConstructC)))
128	(is-false (d::versions vc))
129	(d::add-to-version-history vc
130	:start-revision 100
131	:end-revision 300)
132	(is (= (length (d::versions vc)) 1))
133	(is (= (d::end-revision (first (d::versions vc))) 300))
134	(is (= (d::start-revision (first (d::versions vc))) 100))
135	(d::add-to-version-history vc :start-revision 300)
136	(is (= (length (d::versions vc)) 1))
137	(is (= (d::end-revision (first (d::versions vc))) 0))
138	(is (= (d::start-revision (first (d::versions vc))) 100))
139	(d::add-to-version-history vc :start-revision 500)
140	(is (= (length (d::versions vc)) 2))
141	(let* ((vi-1 (first (d::versions vc)))
142	(vi-2 (second (d::versions vc)))
143	(sr-1 (d::start-revision vi-1))
144	(er-1 (d::end-revision vi-1))
145	(sr-2 (d::start-revision vi-2))
146	(er-2 (d::end-revision vi-2)))
147	(is-true (or (and (= sr-1 100) (= er-1 500)
148	(= sr-2 500) (= er-2 0))
149	(and (= sr-1 500) (= er-1 0)
150	(= sr-2 100) (= er-2 500)))))
151	(d::add-to-version-history vc :start-revision 600)
152	(is (= (length (d::versions vc)) 3))
153	(d::add-to-version-history vc
154	:start-revision 100
155	:end-revision 500)
156	(is (= (length (d::versions vc)) 3))
157	(is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 3))
158	(is (= (length
159	(elephant:get-instances-by-class 'd::VersionedConstructC)) 1))
160	(d::delete-construct vc)
161	(is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 0))
162	(is (= (length
163	(elephant:get-instances-by-class 'd::VersionedConstructC)) 0)))))
164
165
166	(test test-ItemIdentifierC ()
167	"Tests various functions of the ItemIdentifierC class."
168	(with-fixture with-empty-db (db-dir)
169	(let ((ii-1 (make-instance 'ItemIdentifierC
170	:uri "ii-1"))
171	(ii-2 (make-instance 'ItemIdentifierC
172	:uri "ii-2"))
173	(topic-1 (make-instance 'TopicC))
174	(revision-0 0)
175	(revision-1 100)
176	(revision-2 200)
177	(revision-3 300)
178	(revision-3-5 350)
179	(revision-4 400))
180	(setf d:TM-REVISION revision-1)
181	(is-false (identified-construct ii-1))
182	(signals missing-argument-error (make-instance 'ItemIdentifierC))
183	(is-false (item-identifiers topic-1))
184	(add-item-identifier topic-1 ii-1)
185	(is (= (length (d::versions topic-1)) 1))
186	(is-true (find-if #'(lambda(vi)
187	(and (= (d::start-revision vi) revision-1)
188	(= (d::end-revision vi) 0)))
189	(d::versions topic-1)))
190	(is (= (length (item-identifiers topic-1)) 1))
191	(is (eql (first (item-identifiers topic-1)) ii-1))
192	(is (eql (identified-construct ii-1) topic-1))
193	(add-item-identifier topic-1 ii-2 :revision revision-2)
194	(is (= (length (d::versions topic-1)) 2))
195	(is-true (find-if #'(lambda(vi)
196	(and (= (d::start-revision vi) revision-2)
197	(= (d::end-revision vi) 0)))
198	(d::versions topic-1)))
199	(is (= (length (item-identifiers topic-1 :revision revision-0)) 2))
200	(is (= (length (item-identifiers topic-1 :revision revision-1)) 1))
201	(is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1))
202	(is (= (length (union (list ii-1 ii-2)
203	(item-identifiers topic-1 :revision revision-2)))
204	2))
205	(is (= (length (union (list ii-1 ii-2)
206	(item-identifiers topic-1 :revision revision-0)))
207	2))
208	(delete-item-identifier topic-1 ii-1 :revision revision-3)
209	(is (= (length (union (list ii-2)
210	(item-identifiers topic-1
211	:revision revision-0)))
212	1))
213	(is (= (length (union (list ii-1 ii-2)
214	(item-identifiers topic-1
215	:revision revision-2)))
216	2))
217	(delete-item-identifier topic-1 ii-2 :revision revision-3)
218	(is (= (length (d::versions topic-1)) 3))
219	(is-true (find-if #'(lambda(vi)
220	(and (= (d::start-revision vi) revision-3)
221	(= (d::end-revision vi) 0)))
222	(d::versions topic-1)))
223	(is-false (item-identifiers topic-1 :revision revision-3))
224	(add-item-identifier topic-1 ii-1 :revision revision-4)
225	(is (= (length (union (list ii-1)
226	(item-identifiers topic-1 :revision revision-0)))
227	1))
228	(is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2))
229	(is-false (item-identifiers topic-1 :revision revision-3-5)))))
230
231
232	(test test-PersistentIdC ()
233	"Tests various functions of the PersistentIdC class."
234	(with-fixture with-empty-db (db-dir)
235	(let ((psi-1 (make-instance 'PersistentIdC
236	:uri "psi-1"))
237	(psi-2 (make-instance 'PersistentIdC
238	:uri "psi-2"))
239	(topic-1 (make-instance 'TopicC))
240	(revision-0 0)
241	(revision-1 100)
242	(revision-2 200)
243	(revision-3 300)
244	(revision-3-5 350)
245	(revision-4 400))
246	(setf d:TM-REVISION revision-1)
247	(is-false (identified-construct psi-1))
248	(signals missing-argument-error (make-instance 'PersistentIdC))
249	(is-false (psis topic-1))
250	(add-psi topic-1 psi-1)
251	(is (= (length (d::versions topic-1)) 1))
252	(is-true (find-if #'(lambda(vi)
253	(and (= (d::start-revision vi) revision-1)
254	(= (d::end-revision vi) 0)))
255	(d::versions topic-1)))
256	(is (= (length (psis topic-1)) 1))
257	(is (eql (first (psis topic-1)) psi-1))
258	(is (eql (identified-construct psi-1) topic-1))
259	(add-psi topic-1 psi-2 :revision revision-2)
260	(is (= (length (d::versions topic-1)) 2))
261	(is-true (find-if #'(lambda(vi)
262	(and (= (d::start-revision vi) revision-2)
263	(= (d::end-revision vi) 0)))
264	(d::versions topic-1)))
265	(is (= (length (psis topic-1 :revision revision-0)) 2))
266	(is (= (length (psis topic-1 :revision revision-1)) 1))
267	(is (eql (first (psis topic-1 :revision revision-1)) psi-1))
268	(is (= (length (union (list psi-1 psi-2)
269	(psis topic-1 :revision revision-2)))
270	2))
271	(is (= (length (union (list psi-1 psi-2)
272	(psis topic-1 :revision revision-0)))
273	2))
274	(delete-psi topic-1 psi-1 :revision revision-3)
275	(is (= (length (union (list psi-2)
276	(psis topic-1 :revision revision-0)))
277	1))
278	(is (= (length (union (list psi-1 psi-2)
279	(psis topic-1 :revision revision-2)))
280	2))
281	(delete-psi topic-1 psi-2 :revision revision-3)
282	(is (= (length (d::versions topic-1)) 3))
283	(is-true (find-if #'(lambda(vi)
284	(and (= (d::start-revision vi) revision-3)
285	(= (d::end-revision vi) 0)))
286	(d::versions topic-1)))
287	(is-false (psis topic-1 :revision revision-3))
288	(add-psi topic-1 psi-1 :revision revision-4)
289	(is (= (length (union (list psi-1)
290	(psis topic-1 :revision revision-0)))
291	1))
292	(is (= (length (d::slot-p topic-1 'd::psis)) 2))
293	(is-false (psis topic-1 :revision revision-3-5)))))
294
295
296	(test test-SubjectLocatorC ()
297	"Tests various functions of the SubjectLocatorC class."
298	(with-fixture with-empty-db (db-dir)
299	(let ((sl-1 (make-instance 'SubjectLocatorC
300	:uri "sl-1"))
301	(sl-2 (make-instance 'SubjectLocatorC
302	:uri "sl-2"))
303	(topic-1 (make-instance 'TopicC))
304	(revision-0 0)
305	(revision-1 100)
306	(revision-2 200)
307	(revision-3 300)
308	(revision-3-5 350)
309	(revision-4 400))
310	(setf d:TM-REVISION revision-1)
311	(is-false (identified-construct sl-1))
312	(signals missing-argument-error (make-instance 'SubjectLocatorC))
313	(is-false (locators topic-1))
314	(add-locator topic-1 sl-1)
315	(is (= (length (d::versions topic-1)) 1))
316	(is-true (find-if #'(lambda(vi)
317	(and (= (d::start-revision vi) revision-1)
318	(= (d::end-revision vi) 0)))
319	(d::versions topic-1)))
320	(is (= (length (locators topic-1)) 1))
321	(is (eql (first (locators topic-1)) sl-1))
322	(is (eql (identified-construct sl-1) topic-1))
323	(add-locator topic-1 sl-2 :revision revision-2)
324	(is (= (length (d::versions topic-1)) 2))
325	(is-true (find-if #'(lambda(vi)
326	(and (= (d::start-revision vi) revision-2)
327	(= (d::end-revision vi) 0)))
328	(d::versions topic-1)))
329	(is (= (length (locators topic-1 :revision revision-0)) 2))
330	(is (= (length (locators topic-1 :revision revision-1)) 1))
331	(is (eql (first (locators topic-1 :revision revision-1)) sl-1))
332	(is (= (length (union (list sl-1 sl-2)
333	(locators topic-1 :revision revision-2)))
334	2))
335	(is (= (length (union (list sl-1 sl-2)
336	(locators topic-1 :revision revision-0)))
337	2))
338	(delete-locator topic-1 sl-1 :revision revision-3)
339	(is (= (length (d::versions topic-1)) 3))
340	(is-true (find-if #'(lambda(vi)
341	(and (= (d::start-revision vi) revision-3)
342	(= (d::end-revision vi) 0)))
343	(d::versions topic-1)))
344	(is (= (length (union (list sl-2)
345	(locators topic-1 :revision revision-0)))
346	1))
347	(is (= (length (union (list sl-1 sl-2)
348	(locators topic-1 :revision revision-2)))
349	2))
350	(delete-locator topic-1 sl-2 :revision revision-3)
351	(is-false (locators topic-1 :revision revision-3))
352	(add-locator topic-1 sl-1 :revision revision-4)
353	(is (= (length (union (list sl-1)
354	(locators topic-1 :revision revision-0)))
355	1))
356	(is (= (length (d::slot-p topic-1 'd::locators)) 2))
357	(is-false (locators topic-1 :revision revision-3-5)))))
358
359
360	(test test-TopicIdentificationC ()
361	"Tests various functions of the TopicIdentificationC class."
362	(with-fixture with-empty-db (db-dir)
363	(let ((ti-1 (make-instance 'TopicIdentificationC
364	:uri "ti-1"
365	:xtm-id "xtm-id-1"))
366	(ti-2 (make-instance 'TopicIdentificationC
367	:uri "ti-2"
368	:xtm-id "xtm-id-2"))
369	(topic-1 (make-instance 'TopicC))
370	(revision-0 0)
371	(revision-1 100)
372	(revision-2 200)
373	(revision-3 300)
374	(revision-3-5 350)
375	(revision-4 400))
376	(setf d:TM-REVISION revision-1)
377	(is-false (identified-construct ti-1))
378	(signals missing-argument-error (make-instance 'TopicIdentificationC
379	:uri "ti-1"))
380	(signals missing-argument-error (make-instance 'TopicIdentificationC
381	:xtm-id "xtm-id-1"))
382	(is-false (topic-identifiers topic-1))
383	(add-topic-identifier topic-1 ti-1)
384	(is (= (length (d::versions topic-1)) 1))
385	(is-true (find-if #'(lambda(vi)
386	(and (= (d::start-revision vi) revision-1)
387	(= (d::end-revision vi) 0)))
388	(d::versions topic-1)))
389	(is (= (length (topic-identifiers topic-1)) 1))
390	(is (eql (first (topic-identifiers topic-1)) ti-1))
391	(is (eql (identified-construct ti-1) topic-1))
392	(add-topic-identifier topic-1 ti-2 :revision revision-2)
393	(is (= (length (d::versions topic-1)) 2))
394	(is-true (find-if #'(lambda(vi)
395	(and (= (d::start-revision vi) revision-2)
396	(= (d::end-revision vi) 0)))
397	(d::versions topic-1)))
398	(is (= (length (topic-identifiers topic-1 :revision revision-0)) 2))
399	(is (= (length (topic-identifiers topic-1 :revision revision-1)) 1))
400	(is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1))
401	(is (= (length (union (list ti-1 ti-2)
402	(topic-identifiers topic-1 :revision revision-2)))
403	2))
404	(is (= (length (union (list ti-1 ti-2)
405	(topic-identifiers topic-1 :revision revision-0)))
406	2))
407	(delete-topic-identifier topic-1 ti-1 :revision revision-3)
408	(is (= (length (d::versions topic-1)) 3))
409	(is-true (find-if #'(lambda(vi)
410	(and (= (d::start-revision vi) revision-3)
411	(= (d::end-revision vi) 0)))
412	(d::versions topic-1)))
413	(is (= (length (union (list ti-2)
414	(topic-identifiers topic-1 :revision revision-0)))
415	1))
416	(is (= (length (union (list ti-1 ti-2)
417	(topic-identifiers topic-1 :revision revision-2)))
418	2))
419	(delete-topic-identifier topic-1 ti-2 :revision revision-3)
420	(is-false (topic-identifiers topic-1 :revision revision-3))
421	(add-topic-identifier topic-1 ti-1 :revision revision-4)
422	(is (= (length (union (list ti-1)
423	(topic-identifiers topic-1 :revision revision-0)))
424	1))
425	(is (= (length (d::slot-p topic-1 'd::topic-identifiers)) 2))
426	(is-false (topic-identifiers topic-1 :revision revision-3-5)))))
427
428
429	(test test-get-item-by-id ()
430	"Tests the function test-get-item-by-id."
431	(with-fixture with-empty-db (db-dir)
432	(let ((top-id-1 (make-instance 'TopicIdentificationC
433	:uri "topid-1"
434	:xtm-id "xtm-id-1"))
435	(top-id-2 (make-instance 'TopicIdentificationC
436	:uri "topid-2"
437	:xtm-id "xtm-id-2"))
438	(top-id-3-1 (make-instance 'TopicIdentificationC
439	:uri "topid-3"
440	:xtm-id "xtm-id-3"))
441	(top-id-3-2 (make-instance 'TopicIdentificationC
442	:uri "topid-3"
443	:xtm-id "xtm-id-3"))
444	(top-1 (make-instance 'TopicC))
445	(top-2 (make-instance 'TopicC))
446	(top-3 (make-instance 'TopicC))
447	(rev-0 0)
448	(rev-1 100)
449	(rev-2 200))
450	(setf d:TM-REVISION rev-1)
451	(is-false (get-item-by-id "any-top-id" :revision rev-0))
452	(signals object-not-found-error
453	(get-item-by-id "any-top-id" :xtm-id "any-xtm-id" :error-if-nil t))
454	(signals object-not-found-error
455	(get-item-by-id "any-top-id" :error-if-nil t :revision rev-0))
456	(is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id"))
457	(add-topic-identifier top-1 top-id-3-1 :revision rev-1)
458	(add-topic-identifier top-1 top-id-3-2 :revision rev-1)
459	(signals duplicate-identifier-error
460	(get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision rev-1))
461	(add-topic-identifier top-2 top-id-1)
462	(add-topic-identifier top-2 top-id-2 :revision rev-2)
463	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
464	:revision rev-0)))
465	(is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2"
466	:revision rev-0)))
467	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
468	:revision 500)))
469	(is-false (get-item-by-id "topid-2" :xtm-id "xtm-id-2"
470	:revision rev-1))
471	(delete-topic-identifier top-2 top-id-1 :revision rev-2)
472	(is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
473	:revision rev-0))
474	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
475	:revision rev-1)))
476	(add-topic-identifier top-3 top-id-1 :revision rev-2)
477	(is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
478	:revision rev-1)))
479	(d::add-to-version-history top-3 :start-revision rev-2)
480	(is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"
481	:revision rev-0)))
482	(is (eql top-3
483	(get-item-by-id
484	(concatenate 'string "t" (write-to-string
485	(elephant::oid top-3)))
486	:revision rev-0 :xtm-id nil)))
487	(is-false (get-item-by-id
488	(concatenate 'string "t" (write-to-string
489	(elephant::oid top-3)))
490	:revision rev-1 :xtm-id nil)))))
491
492
493	(test test-get-item-by-item-identifier ()
494	"Tests the function test-get-item-by-item-identifier."
495	(with-fixture with-empty-db (db-dir)
496	(let ((ii-1 (make-instance 'ItemIdentifierC
497	:uri "ii-1"))
498	(ii-2 (make-instance 'ItemIdentifierC
499	:uri "ii-2"))
500	(ii-3-1 (make-instance 'ItemIdentifierC
501	:uri "ii-3"))
502	(ii-3-2 (make-instance 'ItemIdentifierC
503	:uri "ii-3"))
504	(top-1 (make-instance 'TopicC))
505	(top-2 (make-instance 'TopicC))
506	(top-3 (make-instance 'TopicC))
507	(rev-0 0)
508	(rev-1 100)
509	(rev-2 200))
510	(setf d:TM-REVISION rev-1)
511	(is-false (get-item-by-id "any-ii-id"))
512	(signals object-not-found-error
513	(get-item-by-item-identifier
514	"any-ii-id" :error-if-nil t :revision rev-1))
515	(signals object-not-found-error
516	(get-item-by-item-identifier
517	"any-ii-id" :error-if-nil t :revision rev-1))
518	(is-false (get-item-by-item-identifier "any-ii-id"))
519	(add-item-identifier top-1 ii-3-1 :revision rev-1)
520	(add-item-identifier top-1 ii-3-2 :revision rev-1)
521	(signals duplicate-identifier-error
522	(get-item-by-item-identifier "ii-3" :revision rev-1))
523	(add-item-identifier top-2 ii-1)
524	(add-item-identifier top-2 ii-2 :revision rev-2)
525	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-0)))
526	(is (eql top-2 (get-item-by-item-identifier "ii-2" :revision rev-0)))
527	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision 500)))
528	(is-false (get-item-by-item-identifier "ii-2" :revision rev-1))
529	(delete-item-identifier top-2 ii-1 :revision rev-2)
530	(is-false (get-item-by-item-identifier "ii-1" :revision rev-0))
531	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1)))
532	(add-item-identifier top-3 ii-1 :revision rev-2)
533	(is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1)))
534	(d::add-to-version-history top-3 :start-revision rev-2)
535	(is (eql top-3 (get-item-by-item-identifier "ii-1" :revision rev-0))))))
536
537
538	(test test-get-item-by-locator ()
539	"Tests the function test-get-item-by-locator."
540	(with-fixture with-empty-db (db-dir)
541	(let ((sl-1 (make-instance 'SubjectLocatorC
542	:uri "sl-1"))
543	(sl-2 (make-instance 'SubjectLocatorC
544	:uri "sl-2"))
545	(sl-3-1 (make-instance 'SubjectLocatorC
546	:uri "sl-3"))
547	(sl-3-2 (make-instance 'SubjectLocatorC
548	:uri "sl-3"))
549	(top-1 (make-instance 'TopicC))
550	(top-2 (make-instance 'TopicC))
551	(top-3 (make-instance 'TopicC))
552	(rev-0 0)
553	(rev-1 100)
554	(rev-2 200))
555	(setf d:TM-REVISION rev-1)
556	(is-false (get-item-by-id "any-sl-id"))
557	(signals object-not-found-error
558	(get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
559	(signals object-not-found-error
560	(get-item-by-locator "any-sl-id" :error-if-nil t :revision rev-0))
561	(is-false (get-item-by-locator "any-sl-id" :revision rev-0))
562	(add-locator top-1 sl-3-1 :revision rev-1)
563	(add-locator top-1 sl-3-2 :revision rev-1)
564	(signals duplicate-identifier-error
565	(get-item-by-locator "sl-3" :revision rev-1))
566	(add-locator top-2 sl-1)
567	(add-locator top-2 sl-2 :revision rev-2)
568	(is (eql top-2 (get-item-by-locator "sl-1" :revision rev-0)))
569	(is (eql top-2 (get-item-by-locator "sl-2" :revision rev-0)))
570	(is (eql top-2 (get-item-by-locator "sl-1" :revision 500)))
571	(is-false (get-item-by-locator "sl-2" :revision rev-1))
572	(delete-locator top-2 sl-1 :revision rev-2)
573	(is-false (get-item-by-locator "sl-1" :revision rev-0))
574	(is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1)))
575	(add-locator top-3 sl-1 :revision rev-2)
576	(is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1)))
577	(d::add-to-version-history top-3 :start-revision rev-2)
578	(is (eql top-3 (get-item-by-locator "sl-1" :revision rev-0))))))
579
580
581	(test test-get-item-by-psi ()
582	"Tests the function test-get-item-by-psi."
583	(with-fixture with-empty-db (db-dir)
584	(let ((psi-1 (make-instance 'PersistentIdC
585	:uri "psi-1"))
586	(psi-2 (make-instance 'PersistentIdC
587	:uri "psi-2"))
588	(psi-3-1 (make-instance 'PersistentIdC
589	:uri "psi-3"))
590	(psi-3-2 (make-instance 'PersistentIdC
591	:uri "psi-3"))
592	(top-1 (make-instance 'TopicC))
593	(top-2 (make-instance 'TopicC))
594	(top-3 (make-instance 'TopicC))
595	(rev-0 0)
596	(rev-1 100)
597	(rev-2 200))
598	(setf d:TM-REVISION rev-1)
599	(is-false (get-item-by-id "any-psi-id"))
600	(signals object-not-found-error
601	(get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0))
602	(signals object-not-found-error
603	(get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0))
604	(is-false (get-item-by-psi "any-psi-id"))
605	(add-psi top-1 psi-3-1 :revision rev-1)
606	(add-psi top-1 psi-3-2 :revision rev-1)
607	(is-false (get-item-by-locator "psi-3" :revision rev-1))
608	(is-false (get-item-by-item-identifier "psi-3" :revision rev-1))
609	(signals duplicate-identifier-error
610	(get-item-by-psi "psi-3" :revision rev-1))
611	(add-psi top-2 psi-1)
612	(add-psi top-2 psi-2 :revision rev-2)
613	(is (eql top-2 (get-item-by-psi "psi-1" :revision rev-0)))
614	(is (eql top-2 (get-item-by-psi "psi-2" :revision rev-0)))
615	(is (eql top-2 (get-item-by-psi "psi-1" :revision 500)))
616	(is-false (get-item-by-psi "psi-2" :revision rev-1))
617	(delete-psi top-2 psi-1 :revision rev-2)
618	(is-false (get-item-by-psi "psi-1" :revision rev-0))
619	(is (eql top-2 (get-item-by-psi "psi-1" :revision rev-1)))
620	(add-psi top-3 psi-1 :revision rev-2)
621	(is (eql top-2 (get-item-by-psi "psi-1" :revision rev-1)))
622	(d::add-to-version-history top-3 :start-revision rev-2)
623	(is (eql top-3 (get-item-by-psi "psi-1" :revision rev-0))))))
624
625
626	(test test-ReifiableConstructC ()
627	"Tests variuas functions of the ReifialeConstructC."
628	(with-fixture with-empty-db (db-dir)
629	(let ((reifier-top (make-instance 'TopicC))
630	(reified-rc (make-instance 'd::AssociationC))
631	(version-0-5 50)
632	(version-1 100)
633	(version-2 200)
634	(version-3 300))
635	(setf TM-REVISION version-1)
636	(is-false (reifier reified-rc))
637	(is-false (reified-construct reifier-top))
638	(add-reifier reified-rc reifier-top :revision version-1)
639	(is (= (length (d::versions reified-rc)) 1))
640	(is-true (find-if #'(lambda(vi)
641	(and (= (d::start-revision vi) version-1)
642	(= (d::end-revision vi) 0)))
643	(d::versions reified-rc)))
644	(is (eql reifier-top (reifier reified-rc)))
645	(is (eql reified-rc (reified-construct reifier-top)))
646	(is (eql reifier-top (reifier reified-rc :revision version-2)))
647	(is (eql reified-rc (reified-construct reifier-top :revision version-2)))
648	(is-false (reifier reified-rc :revision version-0-5))
649	(is-false (reified-construct reifier-top :revision version-0-5))
650	(delete-reifier reified-rc reifier-top :revision version-3)
651	(is (= (length (d::versions reified-rc)) 2))
652	(is-true (find-if #'(lambda(vi)
653	(and (= (d::start-revision vi) version-3)
654	(= (d::end-revision vi) 0)))
655	(d::versions reified-rc))))))
656
657
658	(test test-OccurrenceC ()
659	"Tests various functions of OccurrenceC."
660	(with-fixture with-empty-db (db-dir)
661	(let ((occ-1 (make-instance 'OccurrenceC))
662	(occ-2 (make-instance 'OccurrenceC))
663	(top-1 (make-instance 'TopicC))
664	(top-2 (make-instance 'TopicC))
665	(rev-0 0)
666	(rev-1 100)
667	(rev-2 200)
668	(rev-3 300)
669	(rev-4 400)
670	(rev-5 500)
671	(rev-6 600)
672	(rev-7 700)
673	(rev-8 800))
674	(setf TM-REVISION rev-1)
675	(is-false (parent occ-1 :revision rev-0))
676	(is-false (occurrences top-1 :revision rev-0))
677	(add-occurrence top-1 occ-1 :revision rev-1)
678	(is (= (length (d::versions top-1)) 1))
679	(is-true (find-if #'(lambda(vi)
680	(and (= (d::start-revision vi) rev-1)
681	(= (d::end-revision vi) 0)))
682	(d::versions top-1)))
683	(is (= (length (union (list occ-1)
684	(occurrences top-1 :revision rev-0))) 1))
685	(add-occurrence top-1 occ-2 :revision rev-2)
686	(is (= (length (d::versions top-1)) 2))
687	(is-true (find-if #'(lambda(vi)
688	(and (= (d::start-revision vi) rev-2)
689	(= (d::end-revision vi) 0)))
690	(d::versions top-1)))
691	(is (= (length (union (list occ-1 occ-2)
692	(occurrences top-1 :revision rev-0))) 2))
693	(is (= (length (union (list occ-1)
694	(occurrences top-1 :revision rev-1))) 1))
695	(add-occurrence top-1 occ-2 :revision rev-3)
696	(is (= (length (d::slot-p top-1 'd::occurrences)) 2))
697	(delete-occurrence top-1 occ-1 :revision rev-4)
698	(is (= (length (d::versions top-1)) 4))
699	(is-true (find-if #'(lambda(vi)
700	(and (= (d::start-revision vi) rev-4)
701	(= (d::end-revision vi) 0)))
702	(d::versions top-1)))
703	(is (= (length (union (list occ-2)
704	(occurrences top-1 :revision rev-4))) 1))
705	(is (= (length (union (list occ-2)
706	(occurrences top-1 :revision rev-0))) 1))
707	(is (= (length (union (list occ-1 occ-2)
708	(occurrences top-1 :revision rev-2))) 2))
709	(add-occurrence top-1 occ-1 :revision rev-4)
710	(is (= (length (union (list occ-2 occ-1)
711	(occurrences top-1 :revision rev-0))) 2))
712	(signals tm-reference-error (add-occurrence top-2 occ-1 :revision rev-4))
713	(delete-occurrence top-1 occ-1 :revision rev-5)
714	(is (= (length (union (list occ-2)
715	(occurrences top-1 :revision rev-5))) 1))
716	(add-occurrence top-2 occ-1 :revision rev-5)
717	(is (eql (parent occ-1 :revision rev-0) top-2))
718	(is (eql (parent occ-1 :revision rev-2) top-1))
719	(delete-parent occ-2 top-1 :revision rev-4)
720	(is-false (parent occ-2 :revision rev-4))
721	(is (eql top-1 (parent occ-2 :revision rev-3)))
722	(add-parent occ-2 top-1 :revision rev-5)
723	(is-false (parent occ-2 :revision rev-4))
724	(is (eql top-1 (parent occ-2 :revision rev-0)))
725	(delete-parent occ-2 top-1 :revision rev-6)
726	(add-parent occ-2 top-2 :revision rev-7)
727	(is (= (length (d::versions top-2)) 2))
728	(is-true (find-if #'(lambda(vi)
729	(and (= (d::start-revision vi) rev-7)
730	(= (d::end-revision vi) 0)))
731	(d::versions top-2)))
732	(delete-parent occ-2 top-2 :revision rev-8)
733	(is (= (length (d::versions top-2)) 3))
734	(is-true (find-if #'(lambda(vi)
735	(and (= (d::start-revision vi) rev-8)
736	(= (d::end-revision vi) 0)))
737	(d::versions top-2)))
738	(is-false (parent occ-2 :revision rev-0))
739	(add-parent occ-2 top-1 :revision rev-8)
740	(is (eql top-1 (parent occ-2 :revision rev-0))))))
741
742
743	(test test-VariantC ()
744	"Tests various functions of VariantC."
745	(with-fixture with-empty-db (db-dir)
746	(let ((v-1 (make-instance 'VariantC))
747	(v-2 (make-instance 'VariantC))
748	(name-1 (make-instance 'NameC))
749	(name-2 (make-instance 'NameC))
750	(rev-0 0)
751	(rev-1 100)
752	(rev-2 200)
753	(rev-3 300)
754	(rev-4 400)
755	(rev-5 500)
756	(rev-6 600)
757	(rev-7 700)
758	(rev-8 800))
759	(setf TM-REVISION rev-1)
760	(is-false (parent v-1 :revision rev-0))
761	(is-false (variants name-1 :revision rev-0))
762	(add-variant name-1 v-1 :revision rev-1)
763	(is (= (length (union (list v-1)
764	(variants name-1 :revision rev-0))) 1))
765	(add-variant name-1 v-2 :revision rev-2)
766	(is (= (length (union (list v-1 v-2)
767	(variants name-1 :revision rev-0))) 2))
768	(is (= (length (union (list v-1)
769	(variants name-1 :revision rev-1))) 1))
770	(add-variant name-1 v-2 :revision rev-3)
771	(is (= (length (d::slot-p name-1 'd::variants)) 2))
772	(delete-variant name-1 v-1 :revision rev-4)
773	(is (= (length (union (list v-2)
774	(variants name-1 :revision rev-4))) 1))
775	(is (= (length (union (list v-2)
776	(variants name-1 :revision rev-0))) 1))
777	(is (= (length (union (list v-1 v-2)
778	(variants name-1 :revision rev-2))) 2))
779	(add-variant name-1 v-1 :revision rev-4)
780	(is (= (length (union (list v-2 v-1)
781	(variants name-1 :revision rev-0))) 2))
782	(signals tm-reference-error (add-variant name-2 v-1 :revision rev-4))
783	(delete-variant name-1 v-1 :revision rev-5)
784	(is (= (length (union (list v-2)
785	(variants name-1 :revision rev-5))) 1))
786	(add-variant name-2 v-1 :revision rev-5)
787	(is (eql (parent v-1 :revision rev-0) name-2))
788	(is (eql (parent v-1 :revision rev-2) name-1))
789	(delete-parent v-2 name-1 :revision rev-4)
790	(is-false (parent v-2 :revision rev-4))
791	(is (eql name-1 (parent v-2 :revision rev-3)))
792	(add-parent v-2 name-1 :revision rev-5)
793	(is-false (parent v-2 :revision rev-4))
794	(is (eql name-1 (parent v-2 :revision rev-0)))
795	(delete-parent v-2 name-1 :revision rev-6)
796	(add-parent v-2 name-2 :revision rev-7)
797	(delete-parent v-2 name-2 :revision rev-8)
798	(is-false (parent v-2 :revision rev-0))
799	(add-parent v-2 name-1 :revision rev-8)
800	(is (eql name-1 (parent v-2 :revision rev-0))))))
801
802
803	(test test-NameC ()
804	"Tests various functions of NameC."
805	(with-fixture with-empty-db (db-dir)
806	(let ((name-1 (make-instance 'NameC))
807	(name-2 (make-instance 'NameC))
808	(top-1 (make-instance 'TopicC))
809	(top-2 (make-instance 'TopicC))
810	(rev-0 0)
811	(rev-1 100)
812	(rev-2 200)
813	(rev-3 300)
814	(rev-4 400)
815	(rev-5 500)
816	(rev-6 600)
817	(rev-7 700)
818	(rev-8 800))
819	(setf TM-REVISION rev-1)
820	(is-false (parent name-1 :revision rev-0))
821	(is-false (names top-1 :revision rev-0))
822	(add-name top-1 name-1 :revision rev-1)
823	(is (= (length (d::versions top-1)) 1))
824	(is-true (find-if #'(lambda(vi)
825	(and (= (d::start-revision vi) rev-1)
826	(= (d::end-revision vi) 0)))
827	(d::versions top-1)))
828	(is (= (length (union (list name-1)
829	(names top-1 :revision rev-0))) 1))
830	(add-name top-1 name-2 :revision rev-2)
831	(is (= (length (d::versions top-1)) 2))
832	(is-true (find-if #'(lambda(vi)
833	(and (= (d::start-revision vi) rev-2)
834	(= (d::end-revision vi) 0)))
835	(d::versions top-1)))
836	(is (= (length (union (list name-1 name-2)
837	(names top-1 :revision rev-0))) 2))
838	(is (= (length (union (list name-1)
839	(names top-1 :revision rev-1))) 1))
840	(add-name top-1 name-2 :revision rev-3)
841	(is (= (length (d::slot-p top-1 'd::names)) 2))
842	(delete-name top-1 name-1 :revision rev-4)
843	(is (= (length (d::versions top-1)) 4))
844	(is-true (find-if #'(lambda(vi)
845	(and (= (d::start-revision vi) rev-4)
846	(= (d::end-revision vi) 0)))
847	(d::versions top-1)))
848	(is (= (length (union (list name-2)
849	(names top-1 :revision rev-4))) 1))
850	(is (= (length (union (list name-2)
851	(names top-1 :revision rev-0))) 1))
852	(is (= (length (union (list name-1 name-2)
853	(names top-1 :revision rev-2))) 2))
854	(add-name top-1 name-1 :revision rev-4)
855	(is (= (length (union (list name-2 name-1)
856	(names top-1 :revision rev-0))) 2))
857	(signals tm-reference-error (add-name top-2 name-1 :revision rev-4))
858	(delete-name top-1 name-1 :revision rev-5)
859	(is (= (length (union (list name-2)
860	(names top-1 :revision rev-5))) 1))
861	(add-name top-2 name-1 :revision rev-5)
862	(is (eql (parent name-1 :revision rev-0) top-2))
863	(is (eql (parent name-1 :revision rev-2) top-1))
864	(delete-parent name-2 top-1 :revision rev-4)
865	(is-false (parent name-2 :revision rev-4))
866	(is (eql top-1 (parent name-2 :revision rev-3)))
867	(add-parent name-2 top-1 :revision rev-5)
868	(is-false (parent name-2 :revision rev-4))
869	(is (eql top-1 (parent name-2 :revision rev-0)))
870	(delete-parent name-2 top-1 :revision rev-6)
871	(add-parent name-2 top-2 :revision rev-7)
872	(is (= (length (d::versions top-2)) 2))
873	(is-true (find-if #'(lambda(vi)
874	(and (= (d::start-revision vi) rev-7)
875	(= (d::end-revision vi) 0)))
876	(d::versions top-2)))
877	(delete-parent name-2 top-2 :revision rev-8)
878	(is (= (length (d::versions top-2)) 3))
879	(is-true (find-if #'(lambda(vi)
880	(and (= (d::start-revision vi) rev-8)
881	(= (d::end-revision vi) 0)))
882	(d::versions top-2)))
883	(is-false (parent name-2 :revision rev-0))
884	(add-parent name-2 top-1 :revision rev-8)
885	(is (eql top-1 (parent name-2 :revision rev-0))))))
886
887
888	(test test-TypableC ()
889	"Tests various functions of the base class TypableC."
890	(with-fixture with-empty-db (db-dir)
891	(let ((name-1 (make-instance 'NameC))
892	(name-2 (make-instance 'NameC))
893	(top-1 (make-instance 'TopicC))
894	(top-2 (make-instance 'TopicC))
895	(revision-0 0)
896	(revision-0-5 50)
897	(revision-1 100)
898	(revision-2 200)
899	(revision-3 300))
900	(setf TM-REVISION revision-1)
901	(is-false (instance-of name-1 :revision revision-0))
902	(add-type name-1 top-1)
903	(is (eql top-1 (instance-of name-1)))
904	(is-false (instance-of name-1 :revision revision-0-5))
905	(is (eql top-1 (instance-of name-1 :revision revision-2)))
906	(signals tm-reference-error (add-type name-1 top-2 :revision revision-0))
907	(add-type name-2 top-1 :revision revision-2)
908	(is (= (length (union (list name-1 name-2)
909	(used-as-type top-1 :revision revision-0))) 2))
910	(is (= (length (union (list name-1)
911	(used-as-type top-1 :revision revision-1))) 1))
912	(delete-type name-1 top-1 :revision revision-3)
913	(is-false (instance-of name-1 :revision revision-0))
914	(is (= (length (union (list name-2)
915	(used-as-type top-1 :revision revision-0))) 1))
916	(add-type name-1 top-1 :revision revision-3)
917	(is (eql top-1 (instance-of name-1 :revision revision-0)))
918	(is (= (length (union (list name-1 name-2)
919	(used-as-type top-1 :revision revision-0))) 2))
920	(is (= (length (slot-value top-1 'd::used-as-type)) 2)))))
921
922
923	(test test-ScopableC ()
924	"Tests various functions of the base class ScopableC."
925	(with-fixture with-empty-db (db-dir)
926	(let ((occ-1 (make-instance 'OccurrenceC))
927	(occ-2 (make-instance 'OccurrenceC))
928	(top-1 (make-instance 'TopicC))
929	(top-2 (make-instance 'TopicC))
930	(revision-0 0)
931	(revision-1 100)
932	(revision-2 200)
933	(revision-3 300))
934	(setf TM-REVISION revision-1)
935	(is-false (themes occ-1 :revision revision-0))
936	(is-false (used-as-theme top-1 :revision revision-0))
937	(add-theme occ-1 top-1)
938	(is (= (length (union (list top-1)
939	(themes occ-1 :revision revision-0))) 1))
940	(is (= (length (union (list occ-1)
941	(used-as-theme top-1 :revision revision-0))) 1))
942	(delete-theme occ-1 top-1 :revision revision-2)
943	(is (= (length (union (list top-1)
944	(themes occ-1 :revision revision-1))) 1))
945	(is-false (themes occ-1 :revision revision-0))
946	(is-false (used-as-theme top-1 :revision revision-0))
947	(is-false (themes occ-1 :revision revision-2))
948	(add-theme occ-1 top-1 :revision revision-3)
949	(is (= (length (union (list top-1)
950	(themes occ-1 :revision revision-0))) 1))
951	(is (= (length (slot-value occ-1 'd::themes)) 1))
952	(add-theme occ-1 top-2 :revision revision-2)
953	(is (= (length (union (list top-1 top-2)
954	(themes occ-1 :revision revision-0))) 2))
955	(is (= (length (union (list top-2)
956	(themes occ-1 :revision revision-2))) 1))
957	(is (= (length (union (list top-1 top-2)
958	(themes occ-1 :revision revision-0))) 2))
959	(add-theme occ-2 top-2 :revision revision-3)
960	(is (= (length (union (list top-1 top-2)
961	(themes occ-1 :revision revision-0))) 2))
962	(is (= (length (union (list top-2)
963	(themes occ-2 :revision revision-0))) 1))
964	(is (= (length (union (list occ-1)
965	(used-as-theme top-1 :revision revision-0))) 1))
966	(is (= (length (union (list occ-1 occ-2)
967	(used-as-theme top-2 :revision revision-0))) 2))
968	(is (= (length (slot-value occ-1 'd::themes)) 2))
969	(is (= (length (slot-value occ-2 'd::themes)) 1))
970	(is (= (length (slot-value top-1 'd::used-as-theme)) 1))
971	(is (= (length (slot-value top-2 'd::used-as-theme)) 2)))))
972
973
974	(test test-RoleC ()
975	"Tests various functions of the class RoleC."
976	(with-fixture with-empty-db (db-dir)
977	(let ((role-1 (make-instance 'RoleC))
978	(role-2 (make-instance 'RoleC))
979	(assoc-1 (make-instance 'AssociationC))
980	(assoc-2 (make-instance 'AssociationC))
981	(rev-0 0)
982	(rev-1 100)
983	(rev-2 200)
984	(rev-3 300)
985	(rev-4 400))
986	(setf TM-REVISION rev-1)
987	(is-false (roles assoc-1 :revision rev-0))
988	(is-false (parent role-1 :revision rev-0))
989	(add-parent role-1 assoc-1)
990	(is (= (length (d::versions assoc-1)) 1))
991	(is-true (find-if #'(lambda(vi)
992	(and (= (d::start-revision vi) rev-1)
993	(= (d::end-revision vi) 0)))
994	(d::versions assoc-1)))
995	(is (eql (parent role-1 :revision rev-1) assoc-1))
996	(is (= (length (union (list role-1)
997	(roles assoc-1))) 1))
998	(add-role assoc-1 role-2 :revision rev-2)
999	(is (= (length (d::versions assoc-1)) 2))
1000	(is-true (find-if #'(lambda(vi)
1001	(and (= (d::start-revision vi) rev-2)
1002	(= (d::end-revision vi) 0)))
1003	(d::versions assoc-1)))
1004	(is (= (length (union (list role-1 role-2)
1005	(roles assoc-1 :revision rev-0))) 2))
1006	(is (= (length (union (list role-1)
1007	(roles assoc-1 :revision rev-1))) 1))
1008	(is (eql (parent role-1 :revision rev-0) assoc-1))
1009	(is (eql (parent role-2 :revision rev-2) assoc-1))
1010	(is-false (parent role-2 :revision rev-1))
1011	(signals tm-reference-error (add-parent role-2 assoc-2 :revision rev-2))
1012	(delete-role assoc-1 role-1 :revision rev-3)
1013	(is (= (length (d::versions assoc-1)) 3))
1014	(is-true (find-if #'(lambda(vi)
1015	(and (= (d::start-revision vi) rev-3)
1016	(= (d::end-revision vi) 0)))
1017	(d::versions assoc-1)))
1018	(is-false (parent role-1 :revision rev-0))
1019	(is (= (length (union (list role-2)
1020	(roles assoc-1 :revision rev-0))) 1))
1021	(delete-parent role-2 assoc-1 :revision rev-3)
1022	(is-false (parent role-2 :revision rev-0))
1023	(is (eql assoc-1 (parent role-2 :revision rev-2)))
1024	(is-false (roles assoc-1 :revision rev-0))
1025	(add-role assoc-2 role-1 :revision rev-3)
1026	(add-parent role-2 assoc-2 :revision rev-3)
1027	(is (eql (parent role-2 :revision rev-0) assoc-2))
1028	(is (= (length (union (list role-1 role-2)
1029	(roles assoc-2))) 2))
1030	(add-role assoc-2 role-1 :revision rev-3)
1031	(add-parent role-2 assoc-2 :revision rev-3)
1032	(is (eql (parent role-2 :revision rev-0) assoc-2))
1033	(is (= (length (union (list role-1 role-2)
1034	(roles assoc-2 :revision rev-0))) 2))
1035	(is (= (length (slot-value assoc-1 'roles)) 2))
1036	(is (= (length (slot-value assoc-2 'roles)) 2))
1037	(is (= (length (slot-value role-1 'parent)) 2))
1038	(is (= (length (slot-value role-2 'parent)) 2))
1039	(delete-parent role-1 assoc-2 :revision rev-4)
1040	(is (= (length (d::versions assoc-2)) 2))
1041	(is-true (find-if #'(lambda(vi)
1042	(and (= (d::start-revision vi) rev-4)
1043	(= (d::end-revision vi) 0)))
1044	(d::versions assoc-2))))))
1045
1046
1047	(test test-player ()
1048	"Tests various functions of the topics that are used as player in roles."
1049	(with-fixture with-empty-db (db-dir)
1050	(let ((role-1 (make-instance 'RoleC))
1051	(role-2 (make-instance 'RoleC))
1052	(top-1 (make-instance 'TopicC))
1053	(top-2 (make-instance 'TopicC))
1054	(revision-0 0)
1055	(revision-0-5 50)
1056	(revision-1 100)
1057	(revision-2 200)
1058	(revision-3 300))
1059	(setf TM-REVISION revision-1)
1060	(is-false (player role-1 :revision revision-0))
1061	(add-player role-1 top-1)
1062	(is (eql top-1 (player role-1 :revision revision-0)))
1063	(is-false (player role-1 :revision revision-0-5))
1064	(is (eql top-1 (player role-1 :revision revision-2)))
1065	(add-player role-1 top-1)
1066	(is (eql top-1 (player role-1 :revision revision-0)))
1067	(is-false (player role-1 :revision revision-0-5))
1068	(is (eql top-1 (player role-1 :revision revision-2)))
1069	(signals tm-reference-error (add-player role-1 top-2))
1070	(add-player role-2 top-1 :revision revision-2)
1071	(is (= (length (union (list role-1 role-2)
1072	(player-in-roles top-1 :revision revision-0))) 2))
1073	(is (= (length (union (list role-1)
1074	(player-in-roles top-1
1075	:revision revision-1))) 1))
1076	(delete-player role-1 top-1 :revision revision-3)
1077	(is-false (player role-1 :revision revision-0))
1078	(is (= (length (union (list role-2)
1079	(player-in-roles top-1 :revision revision-0))) 1))
1080	(add-player role-1 top-1 :revision revision-3)
1081	(is (eql top-1 (player role-1 :revision revision-0)))
1082	(is (= (length (union (list role-1 role-2)
1083	(player-in-roles top-1 :revision revision-0))) 2))
1084	(is (= (length (slot-value top-1 'd::player-in-roles)) 2)))))
1085
1086
1087	(test test-TopicMapC ()
1088	"Tests various function of the class TopicMapC."
1089	(with-fixture with-empty-db (db-dir)
1090	(let ((tm-1 (make-instance 'TopicMapC))
1091	(tm-2 (make-instance 'TopicMapC))
1092	(top-1 (make-instance 'TopicC))
1093	(assoc-1 (make-instance 'AssociationC))
1094	(revision-0-5 50)
1095	(revision-1 100))
1096	(setf TM-REVISION revision-1)
1097	(is-false (topics tm-1))
1098	(is-false (in-topicmaps top-1))
1099	(is-false (in-topicmaps assoc-1))
1100	(d::add-to-version-history top-1 :start-revision revision-1)
1101	(add-to-tm tm-1 top-1)
1102	(is (= (length (union (list top-1)
1103	(topics tm-1))) 1))
1104	(is (= (length (union (list tm-1)
1105	(in-topicmaps top-1))) 1))
1106	(is-false (in-topicmaps top-1 :revision revision-0-5))
1107	(d::add-to-version-history assoc-1 :start-revision revision-1)
1108	(add-to-tm tm-1 assoc-1)
1109	(is (= (length (union (list assoc-1)
1110	(associations tm-1))) 1))
1111	(is (= (length (union (list tm-1)
1112	(in-topicmaps assoc-1))) 1))
1113	(is-false (in-topicmaps assoc-1 :revision revision-0-5))
1114	(add-to-tm tm-2 top-1)
1115	(is (= (length (union (list top-1)
1116	(topics tm-2))) 1))
1117	(is (= (length (union (list tm-2 tm-1)
1118	(in-topicmaps top-1))) 2))
1119	(is-false (in-topicmaps top-1 :revision revision-0-5))
1120	(d::add-to-version-history assoc-1 :start-revision revision-1)
1121	(add-to-tm tm-2 assoc-1)
1122	(is (= (length (union (list assoc-1)
1123	(associations tm-2))) 1))
1124	(is (= (length (union (list tm-2 tm-1)
1125	(in-topicmaps assoc-1))) 2))
1126	(is-false (in-topicmaps assoc-1 :revision revision-0-5)))))
1127
1128
1129	(test test-delete-ItemIdentifierC ()
1130	"Tests the function delete-construct of the class ItemIdentifierC."
1131	(with-fixture with-empty-db (db-dir)
1132	(let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
1133	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
1134	(ii-3 (make-instance 'ItemIdentifierC :uri "ii-3"))
1135	(ii-4 (make-instance 'ItemIdentifierC :uri "ii-4"))
1136	(occ-1 (make-instance 'OccurrenceC))
1137	(occ-2 (make-instance 'OccurrenceC))
1138	(name-1 (make-instance 'NameC))
1139	(name-2 (make-instance 'NameC))
1140	(revision-1 100)
1141	(revision-2 200))
1142	(setf TM-REVISION revision-1)
1143	(add-item-identifier occ-1 ii-1 :revision revision-1)
1144	(add-item-identifier occ-1 ii-2 :revision revision-2)
1145	(delete-item-identifier occ-1 ii-1 :revision revision-2)
1146	(add-item-identifier name-1 ii-1 :revision revision-2)
1147	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1148	3))
1149	(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 4))
1150	(delete-construct ii-3)
1151	(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3))
1152	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1153	3))
1154	(delete-construct ii-1)
1155	(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2))
1156	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1157	1))
1158	(delete-construct occ-1)
1159	(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1))
1160	(is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1161	(add-item-identifier occ-2 ii-4 :revision revision-1)
1162	(delete-item-identifier occ-2 ii-4 :revision revision-2)
1163	(add-item-identifier name-2 ii-4 :revision revision-2)
1164	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1165	2))
1166	(delete-construct occ-2)
1167	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1168	1))
1169	(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1))
1170	(is (= (length (union (list ii-4) (item-identifiers name-2))) 1))
1171	(delete-construct name-2)
1172	(is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1173	(is-false (elephant:get-instances-by-class 'ItemIdentifierC)))))
1174
1175
1176
1177	(test test-delete-PersistentIdC ()
1178	"Tests the function delete-construct of the class PersistentIdC."
1179	(with-fixture with-empty-db (db-dir)
1180	(let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1"))
1181	(psi-2 (make-instance 'PersistentIdC :uri "psi-2"))
1182	(psi-3 (make-instance 'PersistentIdC :uri "psi-3"))
1183	(psi-4 (make-instance 'PersistentIdC :uri "psi-4"))
1184	(topic-1 (make-instance 'TopicC))
1185	(topic-2 (make-instance 'TopicC))
1186	(topic-3 (make-instance 'TopicC))
1187	(topic-4 (make-instance 'TopicC))
1188	(revision-1 100)
1189	(revision-2 200))
1190	(setf TM-REVISION revision-1)
1191	(add-psi topic-1 psi-1 :revision revision-1)
1192	(add-psi topic-1 psi-2 :revision revision-2)
1193	(delete-psi topic-1 psi-1 :revision revision-2)
1194	(add-psi topic-3 psi-1 :revision revision-2)
1195	(is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
1196	3))
1197	(is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 4))
1198	(delete-construct psi-3)
1199	(is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 3))
1200	(is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
1201	3))
1202	(delete-construct psi-1)
1203	(is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 2))
1204	(is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
1205	1))
1206	(delete-construct topic-1)
1207	(is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1))
1208	(is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
1209	(add-psi topic-2 psi-4 :revision revision-1)
1210	(delete-psi topic-2 psi-4 :revision revision-2)
1211	(add-psi topic-4 psi-4 :revision revision-2)
1212	(is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
1213	2))
1214	(is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1))
1215	(delete-construct topic-2)
1216	(is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC))
1217	1))
1218	(is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1))
1219	(is (= (length (union (list psi-4) (psis topic-4))) 1)))))
1220
1221
1222	(test test-delete-SubjectLocatorC ()
1223	"Tests the function delete-construct of the class SubjectLocatorC."
1224	(with-fixture with-empty-db (db-dir)
1225	(let ((sl-1 (make-instance 'SubjectLocatorC :uri "sl-1"))
1226	(sl-2 (make-instance 'SubjectLocatorC :uri "sl-2"))
1227	(sl-3 (make-instance 'SubjectLocatorC :uri "sl-3"))
1228	(sl-4 (make-instance 'SubjectLocatorC :uri "sl-4"))
1229	(topic-1 (make-instance 'TopicC))
1230	(topic-2 (make-instance 'TopicC))
1231	(topic-3 (make-instance 'TopicC))
1232	(topic-4 (make-instance 'TopicC))
1233	(revision-1 100)
1234	(revision-2 200))
1235	(setf TM-REVISION revision-1)
1236	(add-locator topic-1 sl-1 :revision revision-1)
1237	(add-locator topic-1 sl-2 :revision revision-2)
1238	(delete-locator topic-1 sl-1 :revision revision-2)
1239	(add-locator topic-3 sl-1 :revision revision-2)
1240	(is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
1241	3))
1242	(is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 4))
1243	(delete-construct sl-3)
1244	(is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 3))
1245	(is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
1246	3))
1247	(delete-construct sl-1)
1248	(is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 2))
1249	(is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
1250	1))
1251	(delete-construct topic-1)
1252	(is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1))
1253	(is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
1254	(add-locator topic-2 sl-4 :revision revision-1)
1255	(delete-locator topic-2 sl-4 :revision revision-2)
1256	(add-locator topic-4 sl-4 :revision revision-2)
1257	(is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
1258	2))
1259	(is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1))
1260	(delete-construct topic-2)
1261	(is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))
1262	1))
1263	(is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1))
1264	(is (= (length (union (list sl-4) (locators topic-4))) 1)))))
1265
1266
1267
1268	(test test-delete-ReifiableConstructC ()
1269	"Tests the function delete-construct of the class ReifiableConstructC"
1270	(with-fixture with-empty-db (db-dir)
1271	(let ((rc-1 (make-instance 'd::ReifiableConstructC))
1272	(rc-2 (make-instance 'd::ReifiableConstructC))
1273	(reifier-1 (make-instance 'TopicC))
1274	(reifier-2 (make-instance 'TopicC))
1275	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
1276	(revision-0 0)
1277	(revision-1 100)
1278	(revision-2 200))
1279	(setf TM-REVISION revision-1)
1280	(add-reifier rc-1 reifier-1)
1281	(add-item-identifier rc-1 ii-1)
1282	(is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
1283	2))
1284	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1285	1))
1286	(is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
1287	1))
1288	(delete-reifier rc-1 reifier-1 :revision revision-2)
1289	(delete-item-identifier rc-1 ii-1 :revision revision-2)
1290	(add-reifier rc-2 reifier-1 :revision revision-2)
1291	(add-item-identifier rc-2 ii-1 :revision revision-2)
1292	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1293	2))
1294	(is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
1295	2))
1296	(delete-construct rc-1)
1297	(is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
1298	1))
1299	(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1300	1))
1301	(is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC))
1302	1))
1303	(is (= (length (union (list ii-1) (item-identifiers rc-2))) 1))
1304	(is (eql reifier-1 (reifier rc-2 :revision revision-0)))
1305	(delete-construct ii-1)
1306	(delete-construct reifier-1)
1307	(is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))
1308	1))
1309	(is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))
1310	(is-false (elephant:get-instances-by-class 'd::ReifierAssociationC))
1311	(delete-construct reifier-2)
1312	(is-false (elephant:get-instances-by-class 'd::ReifierAssociationC)))))
1313
1314
1315	(test test-delete-VariantC ()
1316	"Tests the function delete-construct of the class VariantC"
1317	(with-fixture with-empty-db (db-dir)
1318	(let ((name-1 (make-instance 'NameC))
1319	(name-2 (make-instance 'NameC))
1320	(variant-1 (make-instance 'VariantC))
1321	(variant-2 (make-instance 'VariantC))
1322	(variant-3 (make-instance 'VariantC))
1323	(variant-4 (make-instance 'VariantC))
1324	(revision-1 100)
1325	(revision-2 200))
1326	(setf TM-REVISION revision-1)
1327	(add-variant name-1 variant-1)
1328	(add-variant name-1 variant-2)
1329	(add-variant name-1 variant-3)
1330	(delete-variant name-1 variant-1 :revision revision-2)
1331	(delete-variant name-1 variant-2 :revision revision-2)
1332	(add-variant name-2 variant-1 :revision revision-2)
1333	(add-variant name-2 variant-2 :revision revision-2)
1334	(is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC))
1335	5))
1336	(delete-construct variant-1)
1337	(is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC))
1338	3))
1339	(is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
1340	(delete-construct name-1)
1341	(is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC))
1342	1))
1343	(is (= (length (elephant:get-instances-by-class 'VariantC)) 2))
1344	(delete-construct name-2)
1345	(is (= (length (elephant:get-instances-by-class 'VariantC)) 1))
1346	(is-false (elephant:get-instances-by-class 'd::VariantAssociationC))
1347	(delete-construct variant-4)
1348	(is-false (elephant:get-instances-by-class 'VariantC)))))
1349
1350
1351	(test test-delete-NameC ()
1352	"Tests the function delete-construct of the class NameC"
1353	(with-fixture with-empty-db (db-dir)
1354	(let ((topic-1 (make-instance 'TopicC))
1355	(topic-2 (make-instance 'TopicC))
1356	(name-1 (make-instance 'NameC))
1357	(name-2 (make-instance 'NameC))
1358	(name-3 (make-instance 'NameC))
1359	(name-4 (make-instance 'NameC))
1360	(revision-1 100)
1361	(revision-2 200))
1362	(setf TM-REVISION revision-1)
1363	(add-name topic-1 name-1)
1364	(add-name topic-1 name-2)
1365	(add-name topic-1 name-3)
1366	(delete-name topic-1 name-1 :revision revision-2)
1367	(delete-name topic-1 name-2 :revision revision-2)
1368	(add-name topic-2 name-1 :revision revision-2)
1369	(add-name topic-2 name-2 :revision revision-2)
1370	(is (= (length (elephant:get-instances-by-class 'd::NameAssociationC))
1371	5))
1372	(delete-construct name-1)
1373	(is (= (length (elephant:get-instances-by-class 'd::NameAssociationC))
1374	3))
1375	(is (= (length (elephant:get-instances-by-class 'NameC)) 3))
1376	(delete-construct topic-1)
1377	(is (= (length (elephant:get-instances-by-class 'd::NameAssociationC))
1378	1))
1379	(is (= (length (elephant:get-instances-by-class 'NameC)) 2))
1380	(delete-construct topic-2)
1381	(is (= (length (elephant:get-instances-by-class 'NameC)) 1))
1382	(is-false (elephant:get-instances-by-class 'd::NameAssociationC))
1383	(delete-construct name-4)
1384	(is-false (elephant:get-instances-by-class 'NameC)))))
1385
1386
1387	(test test-delete-OccurrenceC ()
1388	"Tests the function delete-construct of the class OccurrenceC"
1389	(with-fixture with-empty-db (db-dir)
1390	(let ((topic-1 (make-instance 'TopicC))
1391	(topic-2 (make-instance 'TopicC))
1392	(occurrence-1 (make-instance 'OccurrenceC))
1393	(occurrence-2 (make-instance 'OccurrenceC))
1394	(occurrence-3 (make-instance 'OccurrenceC))
1395	(occurrence-4 (make-instance 'OccurrenceC))
1396	(revision-1 100)
1397	(revision-2 200))
1398	(setf TM-REVISION revision-1)
1399	(add-occurrence topic-1 occurrence-1)
1400	(add-occurrence topic-1 occurrence-2)
1401	(add-occurrence topic-1 occurrence-3)
1402	(delete-occurrence topic-1 occurrence-1 :revision revision-2)
1403	(delete-occurrence topic-1 occurrence-2 :revision revision-2)
1404	(add-occurrence topic-2 occurrence-1 :revision revision-2)
1405	(add-occurrence topic-2 occurrence-2 :revision revision-2)
1406	(is (= (length (elephant:get-instances-by-class
1407	'd::OccurrenceAssociationC)) 5))
1408	(delete-construct occurrence-1)
1409	(is (= (length (elephant:get-instances-by-class
1410	'd::OccurrenceAssociationC)) 3))
1411	(is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3))
1412	(delete-construct topic-1)
1413	(is (= (length (elephant:get-instances-by-class
1414	'd::OccurrenceAssociationC)) 1))
1415	(is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2))
1416	(delete-construct topic-2)
1417	(is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 1))
1418	(is-false (elephant:get-instances-by-class 'd::OccurrenceAssociationC))
1419	(delete-construct occurrence-4)
1420	(is-false (elephant:get-instances-by-class 'OccurrenceC)))))
1421
1422
1423	(test test-delete-TypableC ()
1424	"Tests the function delete-construct of the class TypableC"
1425	(with-fixture with-empty-db (db-dir)
1426	(let ((name-1 (make-instance 'NameC))
1427	(name-2 (make-instance 'NameC))
1428	(type-1 (make-instance 'TopicC))
1429	(type-2 (make-instance 'TopicC))
1430	(revision-1 100)
1431	(revision-2 200))
1432	(setf TM-REVISION revision-1)
1433	(add-type name-1 type-1)
1434	(delete-type name-1 type-1 :revision revision-2)
1435	(add-type name-1 type-2 :revision revision-2)
1436	(add-type name-2 type-2)
1437	(is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 3))
1438	(is (= (length (elephant:get-instances-by-class 'd::NameC)) 2))
1439	(delete-construct type-2)
1440	(is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 1))
1441	(is (= (length (elephant:get-instances-by-class 'd::NameC)) 1))
1442	(delete-construct name-1)
1443	(is-false (elephant:get-instances-by-class 'd::TypeAssociationC))
1444	(is-false (elephant:get-instances-by-class 'd::NameC)))))
1445
1446
1447	(test test-delete-ScopableC ()
1448	"Tests the function delete-construct of the class ScopableC"
1449	(with-fixture with-empty-db (db-dir)
1450	(let ((assoc-1 (make-instance 'AssociationC))
1451	(assoc-2 (make-instance 'AssociationC))
1452	(assoc-3 (make-instance 'AssociationC))
1453	(scope-1 (make-instance 'TopicC))
1454	(scope-2 (make-instance 'TopicC))
1455	(scope-3 (make-instance 'TopicC))
1456	(revision-1 100))
1457	(setf TM-REVISION revision-1)
1458	(add-theme assoc-1 scope-1)
1459	(add-theme assoc-1 scope-2)
1460	(add-theme assoc-2 scope-1)
1461	(is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC))
1462	3))
1463	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
1464	(delete-construct scope-1)
1465	(is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC))
1466	1))
1467	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
1468	(delete-construct assoc-1)
1469	(is-false (elephant:get-instances-by-class 'd::ScopeAssociationC))
1470	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 2))
1471	(add-theme assoc-2 scope-3)
1472	(add-theme assoc-3 scope-3)
1473	(is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC))
1474	2))
1475	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 2))
1476	(delete-construct assoc-2)
1477	(is (= (length (union (list scope-3) (themes assoc-3))) 1)))))
1478
1479
1480	(test test-delete-AssociationC ()
1481	"Tests the function delete-construct of the class AssociationC"
1482	(with-fixture with-empty-db (db-dir)
1483	(let ((role-1 (make-instance 'RoleC))
1484	(role-2 (make-instance 'RoleC))
1485	(assoc-1 (make-instance 'AssociationC))
1486	(assoc-2 (make-instance 'AssociationC))
1487	(assoc-3 (make-instance 'AssociationC))
1488	(revision-1 100)
1489	(revision-2 200))
1490	(setf TM-REVISION revision-1)
1491	(add-role assoc-1 role-1)
1492	(delete-role assoc-1 role-1 :revision revision-2)
1493	(add-role assoc-2 role-1 :revision revision-2)
1494	(add-role assoc-2 role-2)
1495	(is (= (length (elephant:get-instances-by-class 'RoleC)) 2))
1496	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
1497	(is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 3))
1498	(delete-construct role-1)
1499	(is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
1500	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
1501	(is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 1))
1502	(delete-role assoc-2 role-2 :revision revision-2)
1503	(add-role assoc-3 role-2 :revision revision-2)
1504	(is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
1505	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 3))
1506	(is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 2))
1507	(delete-construct assoc-3)
1508	(is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
1509	(is (= (length (elephant:get-instances-by-class 'AssociationC)) 2))
1510	(is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC))
1511	1)))))
1512
1513
1514	(test test-delete-RoleC ()
1515	"Tests the function delete-construct of the class RoleC"
1516	(with-fixture with-empty-db (db-dir)
1517	(let ((role-1 (make-instance 'RoleC))
1518	(role-2 (make-instance 'RoleC))
1519	(player-1 (make-instance 'TopicC))
1520	(player-2 (make-instance 'TopicC))
1521	(revision-1 100)
1522	(revision-2 200))
1523	(setf TM-REVISION revision-1)
1524	(add-player role-1 player-1)
1525	(delete-player role-1 player-1 :revision revision-2)
1526	(add-player role-1 player-2 :revision revision-2)
1527	(add-player role-2 player-1)
1528	(is (= (length (elephant:get-instances-by-class 'RoleC)) 2))
1529	(is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC))
1530	3))
1531	(delete-construct player-1)
1532	(is (= (length (elephant:get-instances-by-class 'RoleC)) 1))
1533	(is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC))
1534	1))
1535	(delete-construct role-1)
1536	(is-false (elephant:get-instances-by-class 'RoleC))
1537	(is-false (elephant:get-instances-by-class 'd::PlayerAssociationC)))))
1538
1539
1540	(test test-equivalent-PointerC ()
1541	"Tests the functions equivalent-construct and strictly-equivalent-constructs
1542	depending on PointerC and its subclasses."
1543	(with-fixture with-empty-db (db-dir)
1544	(let ((p-1 (make-instance 'd::PointerC :uri "p-1"))
1545	(tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1"
1546	:xtm-id "xtm-1"))
1547	(tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2"
1548	:xtm-id "xtm-1"))
1549	(tid-3 (make-instance 'd:TopicIdentificationC :uri "tid-1"
1550	:xtm-id "xtm-2"))
1551	(tid-4 (make-instance 'd:TopicIdentificationC :uri "tid-1"
1552	:xtm-id "xtm-1"))
1553	(psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))
1554	(psi-2 (make-instance 'd:PersistentIdC :uri "psi-2"))
1555	(psi-3 (make-instance 'd:PersistentIdC :uri "psi-1"))
1556	(rev-1 100))
1557	(setf TM-REVISION rev-1)
1558	(is-true (d::equivalent-construct p-1 :uri "p-1"))
1559	(is-false (d::equivalent-construct p-1 :uri "p-2"))
1560	(is-true (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-1"))
1561	(is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-1"))
1562	(is-false (d::equivalent-construct tid-1 :uri "tid-1" :xtm-id "xtm-2"))
1563	(is-false (d::equivalent-construct tid-1 :uri "tid-2" :xtm-id "xtm-2"))
1564	(is-true (d::equivalent-construct psi-1 :uri "psi-1"))
1565	(is-false (d::equivalent-construct psi-1 :uri "psi-2"))
1566	(is-false (d::strictly-equivalent-constructs tid-1 tid-1))
1567	(is-false (d::strictly-equivalent-constructs tid-1 tid-2))
1568	(is-false (d::strictly-equivalent-constructs tid-1 tid-3))
1569	(is-true (d::strictly-equivalent-constructs tid-1 tid-4))
1570	(is-false (d::strictly-equivalent-constructs psi-1 psi-1))
1571	(is-false (d::strictly-equivalent-constructs psi-1 psi-2))
1572	(is-true (d::strictly-equivalent-constructs psi-1 psi-3)))))
1573
1574
1575	(test test-equivalent-OccurrenceC ()
1576	"Tests the functions equivalent-construct depending on OccurrenceC."
1577	(with-fixture with-empty-db (db-dir)
1578	(let ((type-1 (make-instance 'd:TopicC))
1579	(type-2 (make-instance 'd:TopicC))
1580	(scope-1 (make-instance 'd:TopicC))
1581	(scope-2 (make-instance 'd:TopicC))
1582	(scope-3 (make-instance 'd:TopicC))
1583	(rev-0-5 50)
1584	(rev-1 100))
1585	(let ((occ-1 (make-construct 'OccurrenceC
1586	:charvalue "occ-1"
1587	:instance-of type-1
1588	:themes (list scope-1 scope-2)
1589	:start-revision rev-1))
1590	(occ-2 (make-construct 'OccurrenceC
1591	:charvalue "occ-1"
1592	:instance-of type-2
1593	:themes (list scope-1 scope-2)
1594	:start-revision rev-1))
1595	(occ-3 (make-construct 'OccurrenceC
1596	:charvalue "occ-1"
1597	:instance-of type-1
1598	:themes (list scope-3 scope-2)
1599	:start-revision rev-1))
1600	(occ-4 (make-construct 'OccurrenceC
1601	:charvalue "occ-2"
1602	:instance-of type-1
1603	:themes (list scope-1 scope-2)
1604	:start-revision rev-1))
1605	(occ-5 (make-construct 'OccurrenceC
1606	:charvalue "occ-1"
1607	:datatype xml-uri
1608	:instance-of type-1
1609	:themes (list scope-1 scope-2)
1610	:start-revision rev-1))
1611	(occ-6 (make-construct 'OccurrenceC
1612	:charvalue "occ-1"
1613	:instance-of type-1
1614	:themes (list scope-1)
1615	:start-revision rev-1)))
1616	(setf TM-REVISION rev-1)
1617	(add-theme occ-6 scope-2)
1618	(is-true (d::equivalent-construct
1619	occ-1 :charvalue "occ-1" :datatype xml-string
1620	:instance-of type-1 :themes (list scope-2 scope-1)))
1621	(is-false (d::equivalent-construct
1622	occ-1 :charvalue "occ-1" :datatype xml-string
1623	:instance-of type-1 :themes (list scope-2 scope-1)
1624	:start-revision rev-0-5))
1625	(is-false (d::equivalent-construct
1626	occ-1 :charvalue "occ-1" :datatype xml-string
1627	:instance-of type-2 :themes (list scope-1 scope-2)))
1628	(is-false (d::equivalent-construct
1629	occ-1 :charvalue "occ-1" :datatype xml-string
1630	:instance-of type-1 :themes (list scope-3 scope-2)))
1631	(is-false (d::equivalent-construct
1632	occ-1 :charvalue "occ-1"
1633	:instance-of type-1 :themes (list scope-1 scope-2)))
1634	(is-false (d::equivalent-construct
1635	occ-1 :charvalue "occ-2" :datatype xml-string
1636	:instance-of type-1 :themes (list scope-2 scope-1)))
1637	(is-false (d::strictly-equivalent-constructs occ-1 occ-1))
1638	(is-false (d::strictly-equivalent-constructs occ-1 occ-2))
1639	(is-false (d::strictly-equivalent-constructs occ-1 occ-3))
1640	(is-false (d::strictly-equivalent-constructs occ-1 occ-4))
1641	(is-false (d::strictly-equivalent-constructs occ-1 occ-5))
1642	(is-true (d::strictly-equivalent-constructs occ-1 occ-6))))))
1643
1644
1645	(test test-equivalent-NameC ()
1646	"Tests the functions equivalent-construct depending on NameC."
1647	(with-fixture with-empty-db (db-dir)
1648	(let ((type-1 (make-instance 'd:TopicC))
1649	(type-2 (make-instance 'd:TopicC))
1650	(scope-1 (make-instance 'd:TopicC))
1651	(scope-2 (make-instance 'd:TopicC))
1652	(scope-3 (make-instance 'd:TopicC))
1653	(variant-1 (make-instance 'd:VariantC))
1654	(variant-2 (make-instance 'd:VariantC))
1655	(rev-0-5 50)
1656	(rev-1 100))
1657	(let ((name-1 (make-construct 'NameC
1658	:charvalue "name-1"
1659	:instance-of type-1
1660	:themes (list scope-1 scope-2)
1661	:start-revision rev-1))
1662	(name-2 (make-construct 'NameC
1663	:charvalue "name-2"
1664	:instance-of type-1
1665	:themes (list scope-1 scope-2)
1666	:start-revision rev-1))
1667	(name-3 (make-construct 'NameC
1668	:charvalue "name-1"
1669	:instance-of type-2
1670	:themes (list scope-1 scope-2)
1671	:start-revision rev-1))
1672	(name-4 (make-construct 'NameC
1673	:charvalue "name-1"
1674	:instance-of type-1
1675	:themes (list scope-3 scope-2)
1676	:start-revision rev-1))
1677	(name-5 (make-construct 'NameC
1678	:charvalue "name-1"
1679	:instance-of type-1
1680	:themes (list scope-2)
1681	:variants (list variant-1 variant-2)
1682	:start-revision rev-1)))
1683	(setf TM-REVISION rev-1)
1684	(add-theme name-5 scope-1)
1685	(is-true (d::equivalent-construct
1686	name-1 :charvalue "name-1" :instance-of type-1
1687	:themes (list scope-2 scope-1)))
1688	(is-false (d::equivalent-construct
1689	name-1 :charvalue "name-1" :instance-of type-1
1690	:themes (list scope-2 scope-1)
1691	:start-revision rev-0-5))
1692	(is-false (d::equivalent-construct
1693	name-1 :charvalue "name-1" :instance-of type-2
1694	:themes (list scope-1 scope-2)))
1695	(is-false (d::equivalent-construct
1696	name-1 :charvalue "name-1" :instance-of type-1
1697	:themes (list scope-3 scope-2)))
1698	(is-false (d::equivalent-construct
1699	name-1 :charvalue "name-2" :instance-of type-1
1700	:themes (list scope-2 scope-1)))
1701	(is-false (d::strictly-equivalent-constructs name-1 name-1))
1702	(is-false (d::strictly-equivalent-constructs name-1 name-2))
1703	(is-false (d::strictly-equivalent-constructs name-1 name-3))
1704	(is-false (d::strictly-equivalent-constructs name-1 name-4))
1705	(is-true (d::strictly-equivalent-constructs name-1 name-5))))))
1706
1707
1708	(test test-equivalent-VariantC ()
1709	"Tests the functions equivalent-construct depending on VariantC."
1710	(with-fixture with-empty-db (db-dir)
1711	(let ((scope-1 (make-instance 'd:TopicC))
1712	(scope-2 (make-instance 'd:TopicC))
1713	(scope-3 (make-instance 'd:TopicC))
1714	(rev-0-5 50)
1715	(rev-1 100))
1716	(let ((var-1 (make-construct 'VariantC
1717	:charvalue "var-1"
1718	:themes (list scope-1 scope-2)
1719	:start-revision rev-1))
1720	(var-2 (make-construct 'VariantC
1721	:charvalue "var-2"
1722	:themes (list scope-1 scope-2)
1723	:start-revision rev-1))
1724	(var-3 (make-construct 'VariantC
1725	:charvalue "var-1"
1726	:themes (list scope-1 scope-3)
1727	:start-revision rev-1))
1728	(var-4 (make-construct 'VariantC
1729	:charvalue "var-1"
1730	:datatype xml-uri
1731	:themes (list scope-1 scope-2)
1732	:start-revision rev-1))
1733	(var-5 (make-construct 'VariantC
1734	:charvalue "var-1"
1735	:themes (list scope-1)
1736	:start-revision rev-1)))
1737	(setf TM-REVISION rev-1)
1738	(add-theme var-5 scope-2)
1739	(is-true (d::equivalent-construct
1740	var-1 :charvalue "var-1" :datatype constants:xml-string
1741	:themes (list scope-2 scope-1)))
1742	(is-false (d::equivalent-construct
1743	var-1 :charvalue "var-1" :datatype constants:xml-string
1744	:themes (list scope-2 scope-1)
1745	:start-revision rev-0-5))
1746	(is-false (d::equivalent-construct
1747	var-1 :charvalue "var-1" :datatype constants:xml-string
1748	:themes (list scope-3 scope-2)))
1749	(is-false (d::equivalent-construct
1750	var-1 :charvalue "var-1"
1751	:themes (list scope-1 scope-2)))
1752	(is-false (d::equivalent-construct
1753	var-1 :charvalue "var-2" :datatype constants:xml-string
1754	:themes (list scope-2 scope-1)))
1755	(is-false (d::strictly-equivalent-constructs var-1 var-1))
1756	(is-false (d::strictly-equivalent-constructs var-1 var-2))
1757	(is-false (d::strictly-equivalent-constructs var-1 var-3))
1758	(is-false (d::strictly-equivalent-constructs var-1 var-4))
1759	(is-true (d::strictly-equivalent-constructs var-1 var-5))))))
1760
1761
1762	(test test-equivalent-RoleC ()
1763	"Tests the functions equivalent-construct depending on RoleC."
1764	(with-fixture with-empty-db (db-dir)
1765	(let ((type-1 (make-instance 'd:TopicC))
1766	(type-2 (make-instance 'd:TopicC))
1767	(player-1 (make-instance 'd:TopicC))
1768	(player-2 (make-instance 'd:TopicC))
1769	(rev-1 100)
1770	(rev-2 200))
1771	(let ((role-1 (make-construct 'RoleC
1772	:player player-1
1773	:instance-of type-1
1774	:start-revision rev-1))
1775	(role-2 (make-construct 'RoleC
1776	:player player-2
1777	:instance-of type-1
1778	:start-revision rev-1))
1779	(role-3 (make-construct 'RoleC
1780	:player player-1
1781	:instance-of type-2
1782	:start-revision rev-1))
1783	(role-4 (make-construct 'RoleC
1784	:instance-of type-1
1785	:start-revision rev-1)))
1786	(setf TM-REVISION rev-1)
1787	(add-player role-4 player-1)
1788	(is-true (d::equivalent-construct role-1 :player player-1
1789	:instance-of type-1))
1790	(is-false (d::equivalent-construct role-1 :player player-2
1791	:instance-of type-1))
1792	(is-false (d::equivalent-construct role-1 :player player-1
1793	:instance-of type-2))
1794	(is-false (d::strictly-equivalent-constructs role-1 role-1))
1795	(is-false (d::strictly-equivalent-constructs role-1 role-2))
1796	(is-false (d::strictly-equivalent-constructs role-1 role-3))
1797	(is-true (d::strictly-equivalent-constructs role-1 role-4))
1798	(setf TM-REVISION rev-2)
1799	(delete-player role-1 player-1 :revision rev-2)
1800	(add-player role-1 player-2)
1801	(delete-type role-1 type-1 :revision rev-2)
1802	(add-type role-1 type-2)
1803	(is-true (d::equivalent-construct role-1 :player player-2
1804	:instance-of type-2))
1805	(is-false (d::equivalent-construct role-1 :player player-1
1806	:instance-of type-2))
1807	(is-false (d::equivalent-construct role-1 :player player-2
1808	:instance-of type-1))))))
1809
1810
1811	(test test-equivalent-AssociationC ()
1812	"Tests the functions equivalent-construct depending on AssociationC."
1813	(with-fixture with-empty-db (db-dir)
1814	(let ((player-1 (make-instance 'TopicC))
1815	(player-2 (make-instance 'TopicC))
1816	(player-3 (make-instance 'TopicC))
1817	(r-type-1 (make-instance 'TopicC))
1818	(r-type-2 (make-instance 'TopicC))
1819	(r-type-3 (make-instance 'TopicC))
1820	(rev-1 100))
1821	(let ((role-1 (list :player player-1 :instance-of r-type-1
1822	:start-revision rev-1))
1823	(role-2 (list :player player-2 :instance-of r-type-2
1824	:start-revision rev-1))
1825	(role-3 (list :player player-3 :instance-of r-type-3
1826	:start-revision rev-1))
1827	(type-1 (make-instance 'd:TopicC))
1828	(type-2 (make-instance 'd:TopicC))
1829	(scope-1 (make-instance 'd:TopicC))
1830	(scope-2 (make-instance 'd:TopicC))
1831	(scope-3 (make-instance 'd:TopicC)))
1832	(let ((assoc-1 (make-construct 'AssociationC
1833	:roles (list role-1 role-2)
1834	:instance-of type-1
1835	:themes (list scope-1 scope-2)
1836	:start-revision rev-1))
1837	(assoc-2 (make-construct 'AssociationC
1838	:roles (list role-1 role-2 role-3)
1839	:instance-of type-1
1840	:themes (list scope-1 scope-2)
1841	:start-revision rev-1))
1842	(assoc-3 (make-construct 'AssociationC
1843	:roles (list role-1 role-3)
1844	:instance-of type-1
1845	:themes (list scope-1 scope-2)
1846	:start-revision rev-1))
1847	(assoc-4 (make-construct 'AssociationC
1848	:roles (list role-1 role-2)
1849	:instance-of type-2
1850	:themes (list scope-1 scope-2)
1851	:start-revision rev-1))
1852	(assoc-5 (make-construct 'AssociationC
1853	:roles (list role-1 role-2)
1854	:instance-of type-1
1855	:themes (list scope-1 scope-3)
1856	:start-revision rev-1))
1857	(assoc-6 (make-construct 'AssociationC
1858	:roles (list role-1)
1859	:instance-of type-1
1860	:themes (list scope-1 scope-2)
1861	:start-revision rev-1)))
1862	(setf TM-REVISION rev-1)
1863	(add-role assoc-6 (apply #'make-construct 'RoleC role-2))
1864	(is-true (d::equivalent-construct
1865	assoc-1 :roles (list role-1 role-2)
1866	:instance-of type-1 :themes (list scope-1 scope-2)))
1867	(is-false (d::equivalent-construct
1868	assoc-1 :roles (list role-1 role-2 role-3)
1869	:instance-of type-1 :themes (list scope-1 scope-2)))
1870	(is-false (d::equivalent-construct
1871	assoc-1 :roles (list role-1)
1872	:instance-of type-1 :themes (list scope-1 scope-2)))
1873	(is-false (d::equivalent-construct
1874	assoc-1 :roles (list role-1 role-3)
1875	:instance-of type-1 :themes (list scope-1 scope-2)))
1876	(is-false (d::equivalent-construct
1877	assoc-1 :roles (list role-1 role-2)
1878	:instance-of type-2 :themes (list scope-1 scope-2)))
1879	(is-false (d::equivalent-construct
1880	assoc-1 :roles (list role-1 role-2)
1881	:instance-of type-2 :themes (list scope-1 scope-3)))
1882	(is-false (d::strictly-equivalent-constructs assoc-1 assoc-1))
1883	(is-false (d::strictly-equivalent-constructs assoc-1 assoc-2))
1884	(is-false (d::strictly-equivalent-constructs assoc-1 assoc-3))
1885	(is-false (d::strictly-equivalent-constructs assoc-1 assoc-4))
1886	(is-false (d::strictly-equivalent-constructs assoc-1 assoc-5))
1887	(is-true (d::strictly-equivalent-constructs assoc-1 assoc-6)))))))
1888
1889
1890	(test test-equivalent-TopicC ()
1891	"Tests the functions equivalent-construct depending on TopicC."
1892	(with-fixture with-empty-db (db-dir)
1893	(let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
1894	(ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
1895	(sl-1 (make-instance 'd:SubjectLocatorC :uri "sl-1"))
1896	(sl-2 (make-instance 'd:SubjectLocatorC :uri "sl-2"))
1897	(psi-1 (make-instance 'd:PersistentIdC :uri "psi-1"))
1898	(psi-2 (make-instance 'd:PersistentIdC :uri "psi-2"))
1899	(tid-1 (make-instance 'd:TopicIdentificationC :uri "tid-1"
1900	:xtm-id "xtm-id-1"))
1901	(tid-2 (make-instance 'd:TopicIdentificationC :uri "tid-2"
1902	:xtm-id "xtm-id-2"))
1903	(rev-1 100))
1904	(let ((top-1 (make-construct 'TopicC
1905	:item-identifiers (list ii-1)
1906	:locators (list sl-1)
1907	:psis (list psi-1)
1908	:topic-identifiers (list tid-1)
1909	:start-revision rev-1))
1910	(top-2 (make-construct 'TopicC
1911	:item-identifiers (list ii-2)
1912	:locators (list sl-2)
1913	:psis (list psi-2)
1914	:topic-identifiers (list tid-2)
1915	:start-revision rev-1)))
1916	(setf TM-REVISION rev-1)
1917	(is-true (d::equivalent-construct top-1
1918	:item-identifiers (list ii-1 ii-2)))
1919	(is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)
1920	:psis (list psi-1 psi-2)
1921	:item-identifiers (list ii-1 ii-2)))
1922	(is-true (d::equivalent-construct top-1 :locators (list sl-1 sl-2)))
1923	(is-true (d::equivalent-construct top-1 :psis (list psi-1 psi-2)))
1924	(is-true (d::equivalent-construct top-1 :topic-identifiers (list tid-1)))
1925	(is-false (d::equivalent-construct top-1 :topic-identifiers (list tid-2)))
1926	(is-false (d::equivalent-construct top-1 :item-identifiers (list ii-2)
1927	:psis (list psi-2)
1928	:locators (list sl-2)))
1929	(is-false (d::strictly-equivalent-constructs top-1 top-1))
1930	(is-false (d::strictly-equivalent-constructs top-1 top-2))))))
1931
1932
1933	(test test-equivalent-TopicMapC ()
1934	"Tests the functions equivalent-construct depending on TopicMapC."
1935	(with-fixture with-empty-db (db-dir)
1936	(let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1"))
1937	(ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2"))
1938	(reifier-1 (make-instance 'd:TopicC))
1939	(reifier-2 (make-instance 'd:TopicC))
1940	(rev-1 100))
1941	(let ((tm-1 (make-construct 'TopicMapC
1942	:item-identifiers (list ii-1)
1943	:reifier reifier-1
1944	:start-revision rev-1))
1945	(tm-2 (make-construct 'TopicMapC
1946	:item-identifiers (list ii-2)
1947	:reifier reifier-2
1948	:start-revision rev-1)))
1949	(setf TM-REVISION rev-1)
1950	(is-true (d::equivalent-construct tm-1
1951	:item-identifiers (list ii-1 ii-2)))
1952	(is-true (d::equivalent-construct tm-1 :reifier reifier-1))
1953	(is-false (d::equivalent-construct tm-1 :item-identifiers (list ii-2)))
1954	(is-false (d::equivalent-construct tm-1 :reifier reifier-2))
1955	(is-false (d::strictly-equivalent-constructs tm-1 tm-1))
1956	(is-false (d::strictly-equivalent-constructs tm-1 tm-2))))))
1957
1958
1959	(test test-class-p ()
1960	"Tests the functions <class>-p."
1961	(let ((identifier (list 'd::IdentifierC 'd::ItemIdentifierC 'd:PersistentIdC
1962	'd:SubjectLocatorC))
1963	(topic-identifier (list 'd::TopicIdentificationC))
1964	(characteristic (list 'd::CharacteristicC 'd:OccurrenceC 'd:NameC
1965	'd:VariantC))
1966	(topic (list 'd:TopicC))
1967	(assoc (list 'd:AssociationC))
1968	(role (list 'd:AssociationC))
1969	(tm (list 'd:TopicMapC)))
1970	(let ((pointer (append identifier topic-identifier))
1971	(reifiable (append topic assoc role tm characteristic))
1972	(typable (append characteristic assoc role))
1973	(scopable (append characteristic assoc)))
1974	(dolist (class pointer)
1975	(is-true (d:PointerC-p class)))
1976	(dolist (class identifier)
1977	(is-true (d:IdentifierC-p class)))
1978	(dolist (class topic-identifier)
1979	(is-true (d:TopicIdentificationC-p class)))
1980	(is-true (d:PersistentIdC-p 'd:PersistentIdC))
1981	(is-true (d:SubjectLocatorC-p 'd:SubjectLocatorC))
1982	(is-true (d:ItemIdentifierC-p 'd:ItemIdentifierC))
1983	(dolist (class characteristic)
1984	(is-true (d:CharacteristicC-p class)))
1985	(is-true (d:OccurrenceC-p 'd:OccurrenceC))
1986	(is-true (d:VariantC-p 'd:VariantC))
1987	(is-true (d:NameC-p 'd:NameC))
1988	(is-true (d:RoleC-p 'd:RoleC))
1989	(is-true (d:AssociationC-p 'd:AssociationC))
1990	(is-true (d:TopicC-p 'd:TopicC))
1991	(is-true (d:TopicMapC-p 'd:TopicMapC))
1992	(dolist (class reifiable)
1993	(is-true (d:ReifiableconstructC-p class)))
1994	(dolist (class scopable)
1995	(is-true (d:ScopableC-p class)))
1996	(dolist (class typable)
1997	(is-true (d:TypableC-p class)))
1998	(dolist (class (append reifiable pointer))
1999	(is-true (d:TopicMapConstructC-p class)))
2000	(dolist (class (append topic tm assoc))
2001	(is-true (d:VersionedConstructC-p class)))
2002	(dolist (class identifier)
2003	(is-false (d:TopicIdentificationC-p class)))
2004	(dolist (class topic-identifier)
2005	(is-false (d:IdentifierC-p class)))
2006	(dolist (class characteristic)
2007	(is-false (d:PointerC-p class))))))
2008
2009
2010	(test test-find-item-by-revision ()
2011	"Tests the function find-item-by-revision."
2012	(with-fixture with-empty-db (db-dir)
2013	(let ((top-1 (make-instance 'TopicC))
2014	(top-2 (make-instance 'TopicC))
2015	(assoc-1 (make-instance 'AssociationC))
2016	(assoc-2 (make-instance 'AssociationC))
2017	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2018	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2019	(psi-1 (make-instance 'PersistentIdC :uri "psi-1"))
2020	(name-1 (make-instance 'NameC))
2021	(name-2 (make-instance 'NameC))
2022	(variant-1 (make-instance 'VariantC))
2023	(role-1 (make-instance 'RoleC))
2024	(rev-0 0)
2025	(rev-0-5 50)
2026	(rev-1 100)
2027	(rev-2 200)
2028	(rev-3 300)
2029	(rev-4 400)
2030	(rev-5 500))
2031	(setf TM-REVISION rev-1)
2032	(d::add-to-version-history top-1 :start-revision rev-1)
2033	(d::add-to-version-history top-1 :start-revision rev-3)
2034	(is (eql top-1 (find-item-by-revision top-1 rev-1)))
2035	(is (eql top-1 (find-item-by-revision top-1 rev-0)))
2036	(is (eql top-1 (find-item-by-revision top-1 rev-4)))
2037	(is (eql top-1 (find-item-by-revision top-1 rev-2)))
2038	(is-false (find-item-by-revision top-1 rev-0-5))
2039	(add-item-identifier top-1 ii-1 :revision rev-3)
2040	(add-item-identifier top-1 ii-2 :revision rev-3)
2041	(add-item-identifier top-1 ii-1 :revision rev-4)
2042	(delete-item-identifier top-1 ii-1 :revision rev-5)
2043	(add-item-identifier top-2 ii-1 :revision rev-5)
2044	(add-psi top-2 psi-1 :revision rev-1)
2045	(is (eql ii-1 (find-item-by-revision ii-1 rev-3 top-1)))
2046	(is (eql ii-1 (find-item-by-revision ii-1 rev-4 top-1)))
2047	(is-false (find-item-by-revision ii-1 rev-2 top-1))
2048	(is-false (find-item-by-revision ii-1 rev-5 top-1))
2049	(is-false (find-item-by-revision ii-1 rev-3))
2050	(is-false (find-item-by-revision ii-1 rev-0 top-1))
2051	(is (eql ii-1 (find-item-by-revision ii-1 rev-5 top-2)))
2052	(add-role assoc-1 role-1 :revision rev-1)
2053	(delete-role assoc-1 role-1 :revision rev-3)
2054	(add-role assoc-2 role-1 :revision rev-5)
2055	(is (eql role-1 (find-item-by-revision role-1 rev-1 assoc-1)))
2056	(is (eql role-1 (find-item-by-revision role-1 rev-2 assoc-1)))
2057	(is (eql role-1 (find-item-by-revision role-1 rev-5 assoc-2)))
2058	(is (eql role-1 (find-item-by-revision role-1 rev-0 assoc-2)))
2059	(is-false (find-item-by-revision role-1 rev-0-5 assoc-1))
2060	(is-false (find-item-by-revision role-1 rev-0 assoc-1))
2061	(is-false (find-item-by-revision role-1 rev-3 assoc-1))
2062	(is-false (find-item-by-revision role-1 rev-3 assoc-2))
2063	(add-name top-1 name-1 :revision rev-1)
2064	(delete-name top-1 name-1 :revision rev-3)
2065	(add-name top-2 name-1 :revision rev-3)
2066	(is (eql name-1 (find-item-by-revision name-1 rev-1 top-1)))
2067	(is (eql name-1 (find-item-by-revision name-1 rev-2 top-1)))
2068	(is (eql name-1 (find-item-by-revision name-1 rev-5 top-2)))
2069	(is (eql name-1 (find-item-by-revision name-1 rev-0 top-2)))
2070	(is-false (find-item-by-revision name-1 rev-0-5 top-1))
2071	(is-false (find-item-by-revision name-1 rev-0 top-1))
2072	(is-false (find-item-by-revision name-1 rev-3 top-1))
2073	(add-variant name-1 variant-1 :revision rev-1)
2074	(delete-variant name-1 variant-1 :revision rev-3)
2075	(add-variant name-2 variant-1 :revision rev-3)
2076	(is (eql variant-1 (find-item-by-revision variant-1 rev-1 name-1)))
2077	(is (eql variant-1 (find-item-by-revision variant-1 rev-2 name-1)))
2078	(is (eql variant-1 (find-item-by-revision variant-1 rev-5 name-2)))
2079	(is (eql variant-1 (find-item-by-revision variant-1 rev-0 name-2)))
2080	(is-false (find-item-by-revision variant-1 rev-0-5 name-1))
2081	(is-false (find-item-by-revision variant-1 rev-0 name-1))
2082	(is-false (find-item-by-revision variant-1 rev-3 name-1)))))
2083
2084
2085
2086	(test test-make-Unknown ()
2087	"Tests the function make-construct corresponding to an unknown class."
2088	(defclass Unknown ()
2089	((value :initarg :value)))
2090	(let ((construct (make-construct 'Unknown :value "value")))
2091	(is-true construct)
2092	(is (string= (slot-value construct 'value) "value"))))
2093
2094
2095	(test test-make-VersionedConstructC ()
2096	"Tests the function make-construct corresponding to VersionedConstructC."
2097	(with-fixture with-empty-db (db-dir)
2098	(let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1"))
2099	(top-1 (make-instance 'TopicC))
2100	(rev-0 0)
2101	(rev-1 100)
2102	(rev-2 200))
2103	(setf TM-REVISION rev-1)
2104	(let ((vc (make-construct 'VersionedConstructC
2105	:start-revision rev-2))
2106	(psi-assoc (make-construct 'd::PersistentIdAssociationC
2107	:start-revision rev-1
2108	:identifier psi-1
2109	:parent-construct top-1)))
2110	(signals missing-argument-error
2111	(make-construct 'd::PersistentIdAssociationC
2112	:start-revision rev-1
2113	:identifier psi-1))
2114	(setf TM-REVISION rev-1)
2115	(signals missing-argument-error (make-construct 'VersionedConstructC))
2116	(is (= (length (d::versions vc)) 1))
2117	(is-true (find-if #'(lambda(vi)
2118	(and (= (d::start-revision vi) rev-2)
2119	(= (d::end-revision vi) rev-0)))
2120	(d::versions vc)))
2121	(is (= (length (d::versions psi-assoc)) 1))
2122	(is-true (find-if #'(lambda(vi)
2123	(and (= (d::start-revision vi) rev-1)
2124	(= (d::end-revision vi) rev-0)))
2125	(d::versions psi-assoc)))))))
2126
2127
2128	(test test-make-TopicIdentificationC ()
2129	"Tests the function make-construct corresponding to TopicIdentificationC."
2130	(with-fixture with-empty-db (db-dir)
2131	(let ((rev-0 0)
2132	(rev-0-5 50)
2133	(rev-1 100)
2134	(top-1 (make-instance 'TopicC)))
2135	(let ((tid-1 (make-construct 'TopicIdentificationC
2136	:uri "tid-1" :xtm-id "xtm-id-1"))
2137	(tid-2 (make-construct 'TopicIdentificationC
2138	:uri "tid-2" :xtm-id "xtm-id-2"
2139	:identified-construct top-1
2140	:start-revision rev-1)))
2141	(signals missing-argument-error (make-construct 'TopicIdentificationC
2142	:uri "uri"))
2143	(signals missing-argument-error (make-construct 'TopicIdentificationC
2144	:xtm-id "xtm-id"))
2145	(setf TM-REVISION rev-1)
2146	(signals missing-argument-error
2147	(make-construct 'TopicIdentificationC :uri "uri"
2148	:identified-construct top-1))
2149	(is (string= (uri tid-1) "tid-1"))
2150	(is (string= (xtm-id tid-1) "xtm-id-1"))
2151	(is-false (d::slot-p tid-1 'd::identified-construct))
2152	(is (string= (uri tid-2) "tid-2"))
2153	(is (string= (xtm-id tid-2) "xtm-id-2"))
2154	(is (= (length (d::slot-p tid-2 'd::identified-construct)) 1))
2155	(is (= (length (d::versions
2156	(first (d::slot-p tid-2 'd::identified-construct)))) 1))
2157	(is (= (d::start-revision
2158	(first (d::versions
2159	(first (d::slot-p tid-2 'd::identified-construct)))))
2160	rev-1))
2161	(is (= (d::end-revision
2162	(first (d::versions
2163	(first (d::slot-p tid-2 'd::identified-construct)))))
2164	rev-0))
2165	(is (eql (identified-construct tid-2 :revision rev-1) top-1))
2166	(is-false (identified-construct tid-2 :revision rev-0-5))
2167	(is (eql (find-item-by-revision tid-2 rev-1 top-1) tid-2))))))
2168
2169
2170	(test test-make-PersistentIdC ()
2171	"Tests the function make-construct corresponding to PersistentIdC."
2172	(with-fixture with-empty-db (db-dir)
2173	(let ((rev-0 0)
2174	(rev-0-5 50)
2175	(rev-1 100)
2176	(top-1 (make-instance 'TopicC)))
2177	(let ((psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
2178	(psi-2 (make-construct 'PersistentIdC
2179	:uri "psi-2"
2180	:identified-construct top-1
2181	:start-revision rev-1)))
2182	(setf TM-REVISION rev-1)
2183	(signals missing-argument-error (make-construct 'PersistentIdC))
2184	(signals missing-argument-error (make-construct 'PersistentIdC :uri "uri"
2185	:identified-construct top-1))
2186	(is (string= (uri psi-1) "psi-1"))
2187	(is-false (d::slot-p psi-1 'd::identified-construct))
2188	(is (string= (uri psi-2) "psi-2"))
2189	(is (= (length (d::slot-p psi-2 'd::identified-construct)) 1))
2190	(is (= (length (d::versions
2191	(first (d::slot-p psi-2 'd::identified-construct)))) 1))
2192	(is (= (d::start-revision
2193	(first (d::versions
2194	(first (d::slot-p psi-2 'd::identified-construct)))))
2195	rev-1))
2196	(is (= (d::end-revision
2197	(first (d::versions
2198	(first (d::slot-p psi-2 'd::identified-construct)))))
2199	rev-0))
2200	(is (eql (identified-construct psi-2 :revision rev-1) top-1))
2201	(is-false (identified-construct psi-2 :revision rev-0-5))
2202	(is (eql (find-item-by-revision psi-2 rev-1 top-1) psi-2))))))
2203
2204
2205	(test test-make-SubjectLocatorC ()
2206	"Tests the function make-construct corresponding to SubjectLocatorC."
2207	(with-fixture with-empty-db (db-dir)
2208	(let ((rev-0 0)
2209	(rev-0-5 50)
2210	(rev-1 100)
2211	(top-1 (make-instance 'TopicC)))
2212	(let ((sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
2213	(sl-2 (make-construct 'SubjectLocatorC
2214	:uri "sl-2"
2215	:identified-construct top-1
2216	:start-revision rev-1)))
2217	(setf TM-REVISION rev-1)
2218	(signals missing-argument-error (make-construct 'SubjectLocatorC))
2219	(signals missing-argument-error (make-construct 'SubjectLocatorC :uri "uri"
2220	:identified-construct top-1))
2221	(is (string= (uri sl-1) "sl-1"))
2222	(is-false (d::slot-p sl-1 'd::identified-construct))
2223	(is (string= (uri sl-2) "sl-2"))
2224	(is (= (length (d::slot-p sl-2 'd::identified-construct)) 1))
2225	(is (= (length (d::versions
2226	(first (d::slot-p sl-2 'd::identified-construct)))) 1))
2227	(is (= (d::start-revision
2228	(first (d::versions
2229	(first (d::slot-p sl-2 'd::identified-construct)))))
2230	rev-1))
2231	(is (= (d::end-revision
2232	(first (d::versions
2233	(first (d::slot-p sl-2 'd::identified-construct)))))
2234	rev-0))
2235	(is (eql (identified-construct sl-2 :revision rev-1) top-1))
2236	(is-false (identified-construct sl-2 :revision rev-0-5))
2237	(is (eql (find-item-by-revision sl-2 rev-1 top-1) sl-2))))))
2238
2239
2240	(test test-make-ItemIdentifierC ()
2241	"Tests the function make-construct corresponding to ItemIdentifierC."
2242	(with-fixture with-empty-db (db-dir)
2243	(let ((rev-0 0)
2244	(rev-0-5 50)
2245	(rev-1 100)
2246	(top-1 (make-instance 'AssociationC)))
2247	(let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
2248	(ii-2 (make-construct 'ItemIdentifierC
2249	:uri "ii-2"
2250	:identified-construct top-1
2251	:start-revision rev-1)))
2252	(setf TM-REVISION rev-1)
2253	(signals missing-argument-error (make-construct 'ItemIdentifierC))
2254	(signals missing-argument-error (make-construct 'ItemIdentifierC :uri "uri"
2255	:identified-construct top-1))
2256	(is (string= (uri ii-1) "ii-1"))
2257	(is-false (d::slot-p ii-1 'd::identified-construct))
2258	(is (string= (uri ii-2) "ii-2"))
2259	(is (= (length (d::slot-p ii-2 'd::identified-construct)) 1))
2260	(is (= (length (d::versions
2261	(first (d::slot-p ii-2 'd::identified-construct)))) 1))
2262	(is (= (d::start-revision
2263	(first (d::versions
2264	(first (d::slot-p ii-2 'd::identified-construct)))))
2265	rev-1))
2266	(is (= (d::end-revision
2267	(first (d::versions
2268	(first (d::slot-p ii-2 'd::identified-construct)))))
2269	rev-0))
2270	(is (eql (identified-construct ii-2 :revision rev-1) top-1))
2271	(is-false (identified-construct ii-2 :revision rev-0-5))
2272	(is (eql (find-item-by-revision ii-2 rev-1 top-1) ii-2))))))
2273
2274
2275	(test test-make-OccurrenceC ()
2276	"Tests the function make-construct corresponding to OccurrenceC."
2277	(with-fixture with-empty-db (db-dir)
2278	(let ((rev-0-5 50)
2279	(rev-1 100)
2280	(type-1 (make-instance 'TopicC))
2281	(theme-1 (make-instance 'TopicC))
2282	(theme-2 (make-instance 'TopicC))
2283	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2284	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2285	(reifier-1 (make-instance 'TopicC))
2286	(top-1 (make-instance 'TopicC)))
2287	(setf TM-REVISION rev-1)
2288	(let ((occ-1 (make-construct 'OccurrenceC))
2289	(occ-2 (make-construct 'OccurrenceC
2290	:charvalue "charvalue"
2291	:datatype "datatype"
2292	:item-identifiers (list ii-1 ii-2)
2293	:reifier reifier-1
2294	:instance-of type-1
2295	:themes (list theme-1 theme-2)
2296	:start-revision rev-1))
2297	(occ-3 (make-construct 'OccurrenceC
2298	:charvalue "charvalue-2"
2299	:parent top-1
2300	:start-revision rev-1)))
2301	(setf TM-REVISION rev-1)
2302	(signals missing-argument-error
2303	(make-construct 'OccurrenceC :item-identifiers (list ii-1)))
2304	(signals missing-argument-error
2305	(make-construct 'OccurrenceC :reifier reifier-1))
2306	(signals missing-argument-error
2307	(make-construct 'OccurrenceC :parent top-1))
2308	(signals missing-argument-error
2309	(make-construct 'OccurrenceC :instance-of type-1))
2310	(signals missing-argument-error
2311	(make-construct 'OccurrenceC :themes (list theme-1)))
2312	(is (string= (charvalue occ-1) ""))
2313	(is (string= (datatype occ-1) xml-string))
2314	(is-false (item-identifiers occ-1))
2315	(is-false (reifier occ-1))
2316	(is-false (instance-of occ-1))
2317	(is-false (themes occ-1))
2318	(is-false (parent occ-1))
2319	(is (string= (charvalue occ-2) "charvalue"))
2320	(is (string= (datatype occ-2) "datatype"))
2321	(is-true (item-identifiers occ-2))
2322	(is (= (length (union (list ii-1 ii-2) (item-identifiers occ-2))) 2))
2323	(is (eql (reifier occ-2) reifier-1))
2324	(is (eql (instance-of occ-2) type-1))
2325	(is-true (themes occ-2))
2326	(is (= (length (union (list theme-1 theme-2) (themes occ-2))) 2))
2327	(is-false (parent occ-2))
2328	(is (eql ii-1 (find-item-by-revision ii-1 rev-1 occ-2)))
2329	(is-false (item-identifiers occ-2 :revision rev-0-5))
2330	(is (eql (parent occ-3) top-1))
2331	(is (eql occ-3 (find-item-by-revision occ-3 rev-1 top-1)))))))
2332
2333
2334	(test test-make-NameC ()
2335	"Tests the function make-construct corresponding to NameC."
2336	(with-fixture with-empty-db (db-dir)
2337	(let ((rev-0-5 50)
2338	(rev-1 100)
2339	(type-1 (make-instance 'TopicC))
2340	(theme-1 (make-instance 'TopicC))
2341	(theme-2 (make-instance 'TopicC))
2342	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2343	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2344	(reifier-1 (make-instance 'TopicC))
2345	(variant-1 (make-instance 'VariantC))
2346	(variant-2 (make-instance 'VariantC))
2347	(top-1 (make-instance 'TopicC)))
2348	(setf TM-REVISION rev-1)
2349	(let ((name-1 (make-construct 'NameC))
2350	(name-2 (make-construct 'NameC
2351	:charvalue "charvalue"
2352	:variants (list variant-1 variant-2)
2353	:item-identifiers (list ii-1 ii-2)
2354	:reifier reifier-1
2355	:instance-of type-1
2356	:themes (list theme-1 theme-2)
2357	:start-revision rev-1))
2358	(name-3 (make-construct 'NameC
2359	:charvalue "charvalue-2"
2360	:parent top-1
2361	:start-revision rev-1)))
2362	(setf TM-REVISION rev-1)
2363	(signals missing-argument-error
2364	(make-construct 'NameC :item-identifiers (list ii-1)))
2365	(signals missing-argument-error
2366	(make-construct 'NameC :reifier reifier-1))
2367	(signals missing-argument-error
2368	(make-construct 'NameC :parent top-1))
2369	(signals missing-argument-error
2370	(make-construct 'NameC :instance-of type-1))
2371	(signals missing-argument-error
2372	(make-construct 'NameC :themes (list theme-1)))
2373	(signals missing-argument-error
2374	(make-construct 'NameC :variants (list variant-1)))
2375	(is (string= (charvalue name-1) ""))
2376	(is-false (item-identifiers name-1))
2377	(is-false (reifier name-1))
2378	(is-false (instance-of name-1))
2379	(is-false (themes name-1))
2380	(is-false (parent name-1))
2381	(is-false (variants name-1))
2382	(is (string= (charvalue name-2) "charvalue"))
2383	(is-true (item-identifiers name-2))
2384	(is (= (length (union (list ii-1 ii-2) (item-identifiers name-2))) 2))
2385	(is (eql (reifier name-2) reifier-1))
2386	(is (eql (instance-of name-2) type-1))
2387	(is-true (themes name-2))
2388	(is (= (length (union (list theme-1 theme-2) (themes name-2))) 2))
2389	(is-true (variants name-2))
2390	(is (= (length (union (list variant-1 variant-2) (variants name-2))) 2))
2391	(is-false (parent name-2))
2392	(is (eql ii-1 (find-item-by-revision ii-1 rev-1 name-2)))
2393	(is-false (item-identifiers name-2 :revision rev-0-5))
2394	(is (eql (parent name-3) top-1))
2395	(is (eql name-3 (find-item-by-revision name-3 rev-1 top-1)))))))
2396
2397
2398	(test test-make-VariantC ()
2399	"Tests the function make-construct corresponding to VariantC."
2400	(with-fixture with-empty-db (db-dir)
2401	(let ((rev-0-5 50)
2402	(rev-1 100)
2403	(theme-1 (make-instance 'TopicC))
2404	(theme-2 (make-instance 'TopicC))
2405	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2406	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2407	(reifier-1 (make-instance 'TopicC))
2408	(name-1 (make-instance 'NameC)))
2409	(setf TM-REVISION rev-1)
2410	(let ((variant-1 (make-construct 'VariantC))
2411	(variant-2 (make-construct 'VariantC
2412	:charvalue "charvalue"
2413	:datatype "datatype"
2414	:item-identifiers (list ii-1 ii-2)
2415	:reifier reifier-1
2416	:themes (list theme-1 theme-2)
2417	:start-revision rev-1))
2418	(variant-3 (make-construct 'VariantC
2419	:charvalue "charvalue-2"
2420	:parent name-1
2421	:start-revision rev-1)))
2422	(setf TM-REVISION rev-1)
2423	(signals missing-argument-error
2424	(make-construct 'VariantC :item-identifiers (list ii-1)))
2425	(signals missing-argument-error
2426	(make-construct 'VariantC :reifier reifier-1))
2427	(signals missing-argument-error
2428	(make-construct 'VariantC :parent name-1))
2429	(signals missing-argument-error
2430	(make-construct 'VariantC :themes (list theme-1)))
2431	(is (string= (charvalue variant-1) ""))
2432	(is (string= (datatype variant-1) xml-string))
2433	(is-false (item-identifiers variant-1))
2434	(is-false (reifier variant-1))
2435	(is-false (instance-of variant-1))
2436	(is-false (themes variant-1))
2437	(is-false (parent variant-1))
2438	(is (string= (charvalue variant-2) "charvalue"))
2439	(is (string= (datatype variant-2) "datatype"))
2440	(is-true (item-identifiers variant-2))
2441	(is (= (length (union (list ii-1 ii-2) (item-identifiers variant-2))) 2))
2442	(is (eql (reifier variant-2) reifier-1))
2443	(is-true (themes variant-2))
2444	(is (= (length (union (list theme-1 theme-2) (themes variant-2))) 2))
2445	(is-false (parent variant-2))
2446	(is (eql ii-1 (find-item-by-revision ii-1 rev-1 variant-2)))
2447	(is-false (item-identifiers variant-2 :revision rev-0-5))
2448	(is (eql (parent variant-3) name-1))
2449	(is (eql variant-3 (find-item-by-revision variant-3 rev-1 name-1)))))))
2450
2451
2452	(test test-make-RoleC ()
2453	"Tests the function make-construct corresponding to RoleC."
2454	(with-fixture with-empty-db (db-dir)
2455	(let ((rev-0-5 50)
2456	(rev-1 100)
2457	(type-1 (make-instance 'TopicC))
2458	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2459	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2460	(player-1 (make-instance 'TopicC))
2461	(reifier-1 (make-instance 'TopicC))
2462	(assoc-1 (make-instance 'AssociationC)))
2463	(setf TM-REVISION rev-1)
2464	(let ((role-1 (make-construct 'RoleC))
2465	(role-2 (make-construct 'RoleC
2466	:item-identifiers (list ii-1 ii-2)
2467	:player player-1
2468	:reifier reifier-1
2469	:instance-of type-1
2470	:start-revision rev-1))
2471	(role-3 (make-construct 'RoleC
2472	:parent assoc-1
2473	:start-revision rev-1)))
2474	(setf TM-REVISION rev-1)
2475	(signals missing-argument-error
2476	(make-construct 'RoleC :item-identifiers (list ii-1)))
2477	(signals missing-argument-error
2478	(make-construct 'RoleC :reifier reifier-1))
2479	(signals missing-argument-error
2480	(make-construct 'RoleC :parent assoc-1))
2481	(signals missing-argument-error
2482	(make-construct 'RoleC :instance-of type-1))
2483	(signals missing-argument-error
2484	(make-construct 'RoleC :player player-1))
2485	(is-false (item-identifiers role-1))
2486	(is-false (reifier role-1))
2487	(is-false (instance-of role-1))
2488	(is-false (parent role-1))
2489	(is-false (player role-1))
2490	(is-true (item-identifiers role-2))
2491	(is (= (length (union (list ii-1 ii-2) (item-identifiers role-2))) 2))
2492	(is (eql (reifier role-2) reifier-1))
2493	(is (eql (instance-of role-2) type-1))
2494	(is-false (parent role-2))
2495	(is (eql (player role-2) player-1))
2496	(is (eql ii-1 (find-item-by-revision ii-1 rev-1 role-2)))
2497	(is-false (item-identifiers role-2 :revision rev-0-5))
2498	(is (eql (parent role-3) assoc-1))
2499	(is (eql role-3 (find-item-by-revision role-3 rev-1 assoc-1)))))))
2500
2501
2502	(test test-make-TopicMapC ()
2503	"Tests the function make-construct corresponding to TopicMapC."
2504	(with-fixture with-empty-db (db-dir)
2505	(let ((rev-1 100)
2506	(top-1 (make-instance 'TopicC))
2507	(top-2 (make-instance 'TopicC))
2508	(top-3 (make-instance 'TopicC))
2509	(assoc-1 (make-instance 'AssociationC))
2510	(assoc-2 (make-instance 'AssociationC))
2511	(assoc-3 (make-instance 'AssociationC))
2512	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2513	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2514	(ii-3 (make-instance 'ItemIdentifierC :uri "ii-3"))
2515	(ii-4 (make-instance 'ItemIdentifierC :uri "ii-4"))
2516	(reifier-1 (make-instance 'TopicC)))
2517	(let ((tm-1 (make-construct 'TopicMapC
2518	:start-revision rev-1
2519	:topics (list top-1 top-2)
2520	:associations (list assoc-1 assoc-2)
2521	:item-identifiers (list ii-1 ii-2)
2522	:reifier reifier-1))
2523	(tm-2 (make-construct 'TopicMapC
2524	:start-revision rev-1
2525	:item-identifiers (list ii-3))))
2526	(setf TM-REVISION rev-1)
2527	(signals missing-argument-error (make-construct 'TopicMapC))
2528	(is (eql (reifier tm-1) reifier-1))
2529	(is (= (length (item-identifiers tm-1)) 2))
2530	(is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2))
2531	(is (= (length (topics tm-1)) 2))
2532	(is (= (length (union (topics tm-1) (list top-1 top-2))) 2))
2533	(is (= (length (associations tm-1)) 2))
2534	(is (= (length (union (associations tm-1) (list assoc-1 assoc-2))) 2))
2535	(is (eql (find-item-by-revision tm-1 rev-1) tm-1))
2536	(is (= (length (item-identifiers tm-2)) 1))
2537	(is (= (length (union (item-identifiers tm-2) (list ii-3))) 1))
2538	(is-false (topics tm-2))
2539	(is-false (associations tm-2))
2540	(is-false (reifier tm-2))
2541	(let ((tm-3 (make-construct 'TopicMapC
2542	:start-revision rev-1
2543	:topics (list top-3)
2544	:associations (list assoc-3)
2545	:item-identifiers (list ii-2 ii-4))))
2546	(is (eql (reifier tm-3) reifier-1))
2547	(is (= (length (item-identifiers tm-3)) 3))
2548	(is (= (length (union (item-identifiers tm-3) (list ii-1 ii-2 ii-4)))
2549	3))
2550	(is (= (length (topics tm-3)) 3))
2551	(is (= (length (union (topics tm-3) (list top-1 top-2 top-3))) 3))
2552	(is (= (length (associations tm-3)) 3))
2553	(is (= (length (union (associations tm-3)
2554	(list assoc-1 assoc-2 assoc-3)))
2555	3))
2556	(is (eql (find-item-by-revision tm-3 rev-1) tm-3)))))))
2557
2558
2559	(test test-make-AssociationC ()
2560	"Tests the function make-construct corresponding to TopicMapC."
2561	(with-fixture with-empty-db (db-dir)
2562	(let ((rev-1 100)
2563	(player-1 (make-instance 'TopicC))
2564	(player-2 (make-instance 'TopicC))
2565	(type-1 (make-instance 'TopicC))
2566	(r-type-1 (make-instance 'TopicC))
2567	(r-type-2 (make-instance 'TopicC))
2568	(theme-1 (make-instance 'TopicC))
2569	(theme-2 (make-instance 'TopicC))
2570	(reifier-1 (make-instance 'TopicC))
2571	(r-reifier-1 (make-instance 'TopicC))
2572	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
2573	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
2574	(r-ii-1 (make-construct 'ItemIdentifierC :uri "r-ii-1"))
2575	(r-ii-2 (make-construct 'ItemIdentifierC :uri "r-ii-2"))
2576	(r-ii-3 (make-construct 'ItemIdentifierC :uri "r-ii-3")))
2577	(let ((role-1 (list :item-identifiers (list r-ii-1) :player player-1
2578	:instance-of r-type-1 :reifier r-reifier-1
2579	:start-revision rev-1))
2580	(role-2 (list :item-identifiers (list r-ii-2 r-ii-3)
2581	:player player-2 :instance-of r-type-2
2582	:start-revision rev-1))
2583	(role-2-2 (list :player player-2 :instance-of r-type-2
2584	:start-revision rev-1))
2585	(tm-1 (make-construct 'TopicMapC :start-revision rev-1))
2586	(tm-2 (make-construct 'TopicMapC :start-revision rev-1)))
2587	(let ((assoc-1 (make-construct 'AssociationC
2588	:start-revision rev-1
2589	:instance-of type-1
2590	:themes (list theme-1 theme-2)
2591	:item-identifiers (list ii-1 ii-2)
2592	:reifier reifier-1
2593	:in-topicmaps (list tm-1 tm-2)
2594	:roles (list role-1 role-2 role-2-2)))
2595	(assoc-2 (make-construct 'AssociationC :start-revision rev-1)))
2596	(setf TM-REVISION rev-1)
2597	(signals missing-argument-error (make-construct 'AssociationC))
2598	(signals missing-argument-error
2599	(make-construct 'AssociationC
2600	:start-revision rev-1
2601	:roles (list (list :player player-1
2602	:instance-of r-type-1))))
2603	(is (eql (instance-of assoc-1) type-1))
2604	(is-true (themes assoc-1))
2605	(is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2))
2606	(is-true (item-identifiers assoc-1))
2607	(is (= (length (union (list ii-1 ii-2) (item-identifiers assoc-1))) 2))
2608	(is (eql (reifier assoc-1) reifier-1))
2609	(is-true (in-topicmaps assoc-1))
2610	(is (= (length (union (list tm-1 tm-2) (in-topicmaps assoc-1))) 2))
2611	(is (= (length (roles assoc-1)) 2))
2612	(is (= (length
2613	(remove-if
2614	#'null
2615	(map
2616	'list
2617	#'(lambda(role)
2618	(when (or (and (eql (player role :revision rev-1)
2619	player-1)
2620	(eql (instance-of role :revision rev-1)
2621	r-type-1)
2622	(= (length (item-identifiers
2623	role :revision rev-1)) 1)
2624	(string=
2625	(uri (first (item-identifiers role)))
2626	"r-ii-1"))
2627	(and (eql (player role :revision rev-1)
2628	player-2)
2629	(eql (instance-of role :revision rev-1)
2630	r-type-2)
2631	(= (length (item-identifiers role)) 2)
2632	(let ((uri-1
2633	(uri (first
2634	(item-identifiers
2635	role :revision rev-1))))
2636	(uri-2
2637	(uri (second
2638	(item-identifiers
2639	role :revision rev-1)))))
2640	(and (or (string= uri-1 "r-ii-2")
2641	(string= uri-2 "r-ii-2"))
2642	(or (string= uri-1 "r-ii-3")
2643	(string= uri-2 "r-ii-3"))))))
2644	role))
2645	(roles assoc-1 :revision rev-1))))
2646	2))
2647	(is (eql (find-item-by-revision assoc-1 rev-1) assoc-1))
2648	(is-false (item-identifiers assoc-2))
2649	(is-false (reifier assoc-2))
2650	(is-false (instance-of assoc-2))
2651	(is-false (themes assoc-2))
2652	(is-false (roles assoc-2))
2653	(is-false (in-topicmaps assoc-2))
2654	(let ((assoc-3 (make-construct 'AssociationC
2655	:start-revision rev-1
2656	:roles (list role-1 role-2)
2657	:instance-of type-1
2658	:themes (list theme-1 theme-2))))
2659	(is (eql (instance-of assoc-3) type-1))
2660	(is-true (themes assoc-3))
2661	(is (= (length (union (list theme-1 theme-2) (themes assoc-3))) 2))
2662	(is-true (item-identifiers assoc-3))
2663	(is (= (length (union (list ii-1 ii-2) (item-identifiers assoc-3))) 2))
2664	(is (eql (reifier assoc-3) reifier-1))
2665	(is-true (in-topicmaps assoc-3))
2666	(is (= (length (union (list tm-1 tm-2) (in-topicmaps assoc-3))) 2))
2667	(is (= (length (roles assoc-3)) 2))))))))
2668
2669
2670	(test test-make-TopicC ()
2671	"Tests the function make-construct corresponding to TopicC."
2672	(with-fixture with-empty-db (db-dir)
2673	(let ((rev-1 100)
2674	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
2675	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
2676	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
2677	(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
2678	(psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
2679	(psi-3 (make-construct 'PersistentIdC :uri "psi-3"))
2680	(sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
2681	(sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
2682	(sl-3 (make-construct 'SubjectLocatorC :uri "sl-3"))
2683	(variant-1 (make-construct 'VariantC :datatype "dt-1"
2684	:charvalue "cv-1"))
2685	(variant-2 (make-construct 'VariantC :datatype "dt-2"
2686	:charvalue "cv-2"))
2687	(type-1 (make-instance 'TopicC))
2688	(type-2 (make-instance 'TopicC))
2689	(type-3 (make-instance 'TopicC))
2690	(theme-1 (make-instance 'TopicC))
2691	(theme-2 (make-instance 'TopicC))
2692	(theme-3 (make-instance 'TopicC)))
2693	(let ((name-1 (make-construct 'NameC :charvalue "cv-3"
2694	:start-revision rev-1
2695	:variants (list variant-1)
2696	:instance-of type-1
2697	:themes (list theme-1 theme-2)))
2698	(name-2 (make-construct 'NameC :charvalue "cv-4"
2699	:start-revision rev-1
2700	:variants (list variant-2)
2701	:instance-of type-2
2702	:themes (list theme-3 theme-2)))
2703	(occ-1 (make-construct 'OccurrenceC :charvalue "cv-5"
2704	:start-revision rev-1
2705	:themes (list theme-1)
2706	:instance-of type-3)))
2707	(let ((top-1 (make-construct 'TopicC :start-revision rev-1))
2708	(top-2 (make-construct 'TopicC :start-revision rev-1
2709	:item-identifiers (list ii-1 ii-2)
2710	:psis (list psi-1 psi-2 psi-3)
2711	:locators (list sl-1 sl-2)
2712	:names (list name-1)
2713	:occurrences (list occ-1))))
2714	(setf TM-REVISION rev-1)
2715	(signals missing-argument-error (make-construct 'TopicC))
2716	(is-false (item-identifiers top-1))
2717	(is-false (psis top-1))
2718	(is-false (locators top-1))
2719	(is-false (names top-1))
2720	(is-false (occurrences top-1))
2721	(is (eql (find-item-by-revision top-1 rev-1) top-1))
2722	(is (= (length (item-identifiers top-2)) 2))
2723	(is (= (length (union (list ii-1 ii-2) (item-identifiers top-2))) 2))
2724	(is (= (length (locators top-2)) 2))
2725	(is (= (length (union (list sl-1 sl-2) (locators top-2))) 2))
2726	(is (= (length (psis top-2)) 3))
2727	(is (= (length (union (list psi-1 psi-2 psi-3) (psis top-2))) 3))
2728	(is (= (length (names top-2)) 1))
2729	(is (eql (first (names top-2)) name-1))
2730	(is (= (length (occurrences top-2)) 1))
2731	(is (eql (first (occurrences top-2)) occ-1))
2732	(is (eql (find-item-by-revision occ-1 rev-1 top-2) occ-1))
2733	(let ((top-3 (make-construct 'TopicC :start-revision rev-1
2734	:item-identifiers (list ii-2 ii-3)
2735	:locators (list sl-3)
2736	:names (list name-2))))
2737	(is (= (length (item-identifiers top-3)) 3))
2738	(is (= (length (union (list ii-1 ii-2 ii-3)
2739	(item-identifiers top-3))) 3))
2740	(is (= (length (locators top-3)) 3))
2741	(is (= (length (union (list sl-1 sl-2 sl-3) (locators top-3))) 3))
2742	(is (= (length (psis top-3)) 3))
2743	(is (= (length (union (list psi-1 psi-2 psi-3) (psis top-3))) 3))
2744	(is (= (length (names top-3)) 2))
2745	(is (= (length (union (list name-1 name-2) (names top-3))) 2))
2746	(is (= (length (occurrences top-3)) 1))
2747	(is (eql (first (occurrences top-3)) occ-1))))))))
2748
2749
2750	(test test-find-oldest-construct ()
2751	"Tests the generic find-oldest-construct."
2752	(with-fixture with-empty-db (db-dir)
2753	(let ((rev-1 100)
2754	(rev-2 200)
2755	(rev-3 300))
2756	(let ((theme-1 (make-construct 'TopicC :start-revision rev-1))
2757	(theme-2 (make-construct 'TopicC :start-revision rev-1))
2758	(player-1 (make-construct 'TopicC :start-revision rev-1))
2759	(player-2 (make-construct 'TopicC :start-revision rev-1)))
2760	(let ((top-1 (make-instance 'TopicC))
2761	(top-2 (make-instance 'TopicC))
2762	(tm-1 (make-instance 'TopicMapC))
2763	(tm-2 (make-instance 'TopicMapC))
2764	(assoc-1 (make-instance 'AssociationC))
2765	(assoc-2 (make-instance 'AssociationC))
2766	(ii-1 (make-instance 'ItemIdentifierC :uri "ii-1"))
2767	(ii-2 (make-instance 'ItemIdentifierC :uri "ii-2"))
2768	(variant-1 (make-construct 'VariantC
2769	:start-revision rev-1
2770	:charvalue "var-1"
2771	:themes (list theme-1)))
2772	(variant-2 (make-construct 'VariantC
2773	:start-revision rev-1
2774	:charvalue "var-2"
2775	:themes (list theme-2)))
2776	(name-1 (make-instance 'NameC))
2777	(name-2 (make-instance 'NameC))
2778	(role-1 (make-construct 'RoleC
2779	:start-revision rev-1
2780	:player player-1))
2781	(role-2 (make-construct 'RoleC
2782	:start-revision rev-1
2783	:player player-2)))
2784	(setf TM-REVISION rev-1)
2785	(is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
2786	(add-item-identifier top-1 ii-1 :revision rev-3)
2787	(is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
2788	(add-item-identifier assoc-1 ii-2 :revision rev-2)
2789	(is (eql ii-2 (d::find-oldest-construct ii-1 ii-2)))
2790	(add-item-identifier top-2 ii-1 :revision rev-1)
2791	(is (eql ii-1 (d::find-oldest-construct ii-1 ii-2)))
2792	(is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
2793	(add-variant name-1 variant-1 :revision rev-3)
2794	(is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
2795	(add-variant name-1 variant-2 :revision rev-2)
2796	(is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) ;x
2797	(add-variant name-2 variant-1 :revision rev-1)
2798	(is (eql variant-1 (d::find-oldest-construct variant-1 variant-2)))
2799	(is (eql role-1 (d::find-oldest-construct role-1 role-2)))
2800	(add-role assoc-1 role-1 :revision rev-3)
2801	(is (eql role-1 (d::find-oldest-construct role-1 role-2))) ;x
2802	(add-role assoc-1 role-2 :revision rev-2)
2803	(is (eql role-2 (d::find-oldest-construct role-1 role-2)))
2804	(add-role assoc-2 role-1 :revision rev-1)
2805	(is (eql role-1 (d::find-oldest-construct role-1 role-2)))
2806	(is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
2807	(d::add-to-version-history tm-1 :start-revision rev-3)
2808	(is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
2809	(d::add-to-version-history tm-2 :start-revision rev-1)
2810	(is (eql tm-2 (d::find-oldest-construct tm-1 tm-2)))
2811	(d::add-to-version-history tm-1 :start-revision rev-1)
2812	(is (eql tm-1 (d::find-oldest-construct tm-1 tm-2)))
2813	(is (eql tm-2 (d::find-oldest-construct tm-2 tm-1))))))))
2814
2815
2816	(test test-move-referenced-constructs-ReifiableConstructC ()
2817	"Tests the generic move-referenced-constructs corresponding to ReifiableConstructC."
2818	(with-fixture with-empty-db (db-dir)
2819	(let ((rev-1 100)
2820	(rev-2 200)
2821	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
2822	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
2823	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")))
2824	(let ((reifier-1 (make-construct 'TopicC :start-revision rev-2))
2825	(reifier-2 (make-construct 'TopicC :start-revision rev-1))
2826	(theme-1 (make-construct 'TopicC :start-revision rev-1))
2827	(theme-2 (make-construct 'TopicC :start-revision rev-1))
2828	(type-1 (make-construct 'TopicC :start-revision rev-1))
2829	(type-2 (make-construct 'TopicC :start-revision rev-1)))
2830	(let ((occ-1 (make-construct 'OccurrenceC
2831	:start-revision rev-1
2832	:item-identifiers (list ii-1 ii-2)
2833	:reifier reifier-1
2834	:instance-of type-2
2835	:themes (list theme-1 theme-2)
2836	:charvalue "occ"))
2837	(occ-2 (make-construct 'OccurrenceC
2838	:start-revision rev-2
2839	:item-identifiers (list ii-3)
2840	:charvalue "occ"
2841	:instance-of type-1
2842	:themes (list theme-1 theme-2)
2843	:reifier reifier-2)))
2844	(setf TM-REVISION rev-1)
2845	(delete-type occ-1 type-2 :revision rev-2)
2846	(add-type occ-1 type-1 :revision rev-2)
2847	(is (eql reifier-1 (reifier occ-1 :revision rev-2)))
2848	(is (eql reifier-2 (reifier occ-2 :revision rev-2)))
2849	(is (= (length (union (list ii-1 ii-2 reifier-2)
2850	(d::move-referenced-constructs occ-1 occ-2
2851	:revision rev-2)))
2852	3))
2853	(is (= (length (item-identifiers occ-2 :revision rev-2)) 3))
2854	(is (= (length (union (item-identifiers occ-2 :revision rev-2)
2855	(list ii-1 ii-2 ii-3)))
2856	3))
2857	(is-false (item-identifiers occ-1 :revision rev-2))
2858	(is-false (reifier occ-1 :revision rev-2))
2859	(is (eql (reifier occ-2 :revision rev-2) reifier-2))
2860	(is-true (d::marked-as-deleted-p reifier-1)))))))
2861
2862
2863	(test test-move-referenced-constructs-NameC ()
2864	"Tests the generic move-referenced-constructs corresponding to NameC."
2865	(with-fixture with-empty-db (db-dir)
2866	(let ((rev-1 100)
2867	(rev-2 200))
2868	(let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
2869	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
2870	(reifier-1 (make-construct 'TopicC :start-revision rev-1))
2871	(reifier-2 (make-construct 'TopicC :start-revision rev-2))
2872	(type-1 (make-construct 'TopicC :start-revision rev-1))
2873	(theme-1 (make-construct 'TopicC :start-revision rev-1))
2874	(theme-2 (make-construct 'TopicC :start-revision rev-1)))
2875	(let ((variant-1 (make-construct 'VariantC
2876	:start-revision rev-1
2877	:themes (list theme-1)
2878	:charvalue "var-1"
2879	:item-identifiers (list ii-1)
2880	:reifier reifier-2))
2881	(variant-2 (make-construct 'VariantC
2882	:start-revision rev-1
2883	:themes (list theme-1)
2884	:charvalue "var-2+4"))
2885	(variant-3 (make-construct 'VariantC
2886	:start-revision rev-1
2887	:themes (list theme-2)
2888	:charvalue "var-3"))
2889	(variant-4 (make-construct 'VariantC
2890	:start-revision rev-1
2891	:themes (list theme-1)
2892	:charvalue "var-2+4")))
2893	(let ((name-1 (make-construct 'NameC
2894	:start-revision rev-1
2895	:charvalue "name"
2896	:variants (list variant-1 variant-2)
2897	:instance-of type-1
2898	:item-identifiers (list ii-2)))
2899	(name-2 (make-construct 'NameC
2900	:start-revision rev-1
2901	:charvalue "name"
2902	:variants (list variant-3 variant-4)
2903	:instance-of type-1
2904	:reifier reifier-1)))
2905	(setf TM-REVISION rev-1)
2906	(is (= (length (union (list variant-1 variant-2)
2907	(variants name-1))) 2))
2908	(is (= (length (union (list variant-3 variant-4)
2909	(variants name-2))) 2))
2910	(is-false (reifier name-1))
2911	(is (eql reifier-1 (reifier name-2)))
2912	(is (= (length
2913	(union (list variant-1 variant-2 ii-2)
2914	(d::move-referenced-constructs name-1 name-2
2915	:revision rev-2)))
2916	3))
2917	(is-false (item-identifiers name-1 :revision rev-2))
2918	(is-false (reifier name-1 :revision rev-2))
2919	(is-false (variants name-1 :revision rev-2))
2920	(is (= (length (item-identifiers name-2 :revision rev-2)) 1))
2921	(is (= (length (union (list ii-2)
2922	(item-identifiers name-2 :revision rev-2)))
2923	1))
2924	(is (eql (reifier name-2 :revision rev-2) reifier-1))
2925	(is (= (length (variants name-2 :revision rev-2)) 3))
2926	(is (= (length (union (list variant-1 variant-3 variant-4)
2927	(variants name-2 :revision rev-2)))
2928	3))
2929	(is-true
2930	(find-if
2931	#'(lambda(var)
2932	(and (= (length (item-identifiers var :revision rev-2)) 1)
2933	(string= (uri (first (item-identifiers var
2934	:revision rev-2)))
2935	"ii-1")))
2936	(variants name-2 :revision rev-2)))
2937	(is-true
2938	(find-if #'(lambda(var)
2939	(eql (reifier var :revision rev-2) reifier-2))
2940	(variants name-2 :revision rev-2)))))))))
2941
2942
2943	(test test-merge-constructs-TopicC-1 ()
2944	"Tests the generic merge-constructs corresÃŒponding to TopicC."
2945	(with-fixture with-empty-db (db-dir)
2946	(let ((rev-1 100)
2947	(rev-2 200)
2948	(rev-3 300))
2949	(let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
2950	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
2951	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
2952	(sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
2953	(sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
2954	(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
2955	(psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
2956	(tid-1 (make-construct 'TopicIdentificationC :uri "tid-1"
2957	:xtm-id "xtm-1"))
2958	(tid-2 (make-construct 'TopicIdentificationC :uri "tid-2"
2959	:xtm-id "xtm-2"))
2960	(type-1 (make-construct 'TopicC :start-revision rev-1))
2961	(type-2 (make-construct 'TopicC :start-revision rev-1))
2962	(theme-1 (make-construct 'TopicC :start-revision rev-1))
2963	(theme-2 (make-construct 'TopicC :start-revision rev-1)))
2964	(let ((variant-1 (make-construct 'VariantC
2965	:start-revision rev-1
2966	:charvalue "var-1"
2967	:themes (list theme-1)))
2968	(variant-2 (make-construct 'VariantC
2969	:start-revision rev-2
2970	:charvalue "var-2"
2971	:themes (list theme-2)))
2972	(variant-3 (make-construct 'VariantC
2973	:start-revision rev-1
2974	:charvalue "var-1"
2975	:themes (list theme-1)))
2976	(occ-1 (make-construct 'OccurrenceC
2977	:start-revision rev-1
2978	:charvalue "occ-1"
2979	:instance-of type-1
2980	:themes (list theme-1)))
2981	(occ-2 (make-construct 'OccurrenceC
2982	:start-revision rev-1
2983	:charvalue "occ-2"
2984	:instance-of type-2))
2985	(occ-3 (make-construct 'OccurrenceC
2986	:start-revision rev-2
2987	:item-identifiers (list ii-3)
2988	:charvalue "occ-1"
2989	:instance-of type-1
2990	:themes (list theme-1))))
2991	(let ((name-1 (make-construct 'NameC
2992	:start-revision rev-1
2993	:charvalue "name-1"
2994	:instance-of type-1))
2995	(name-2 (make-construct 'NameC
2996	:start-revision rev-2
2997	:charvalue "name-2"
2998	:instance-of type-1
2999	:variants (list variant-1 variant-2)))
3000	(name-3 (make-construct 'NameC
3001	:start-revision rev-1
3002	:charvalue "name-1"
3003	:instance-of type-1
3004	:variants (list variant-3))))
3005	(let ((top-1 (make-construct 'TopicC
3006	:start-revision rev-1
3007	:topic-identifiers (list tid-1)
3008	:item-identifiers (list ii-1)
3009	:locators (list sl-1)
3010	:psis (list psi-1)
3011	:names (list name-1 name-2)
3012	:occurrences (list occ-1 occ-2)))
3013	(top-2 (make-construct 'TopicC
3014	:start-revision rev-2
3015	:topic-identifiers (list tid-2)
3016	:item-identifiers (list ii-2)
3017	:locators (list sl-2)
3018	:psis (list psi-2)
3019	:names (list name-3)
3020	:occurrences (list occ-3))))
3021	(setf TM-REVISION rev-3)
3022	(let ((top (d::merge-constructs top-1 top-2 :revision rev-3)))
3023	(is (eql top top-1))
3024	(is-true (d::marked-as-deleted-p top-2))
3025	(is-false (append (psis top-2) (item-identifiers top-2)
3026	(locators top-2) (topic-identifiers top-2)
3027	(names top-2) (occurrences top-2)))
3028	(setf TM-REVISION rev-2)
3029	(is (= (length (append (psis top-2) (item-identifiers top-2)
3030	(locators top-2) (topic-identifiers top-2)
3031	(names top-2) (occurrences top-2)))
3032	6))
3033	(setf TM-REVISION rev-3)
3034	(is-false (set-exclusive-or (list ii-1 ii-2)
3035	(item-identifiers top-1)))
3036	(is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1)))
3037	(is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
3038	(is-false (set-exclusive-or (list tid-1 tid-2)
3039	(topic-identifiers top-1)))
3040	(is-false (set-exclusive-or (list psi-1)
3041	(psis top-1 :revision rev-2)))
3042	(is-false (set-exclusive-or (list name-1 name-2)
3043	(names top-1)))
3044	(is-false (set-exclusive-or (variants name-1)
3045	(list variant-3)))
3046	(is-false (variants name-3))
3047	(is-false (set-exclusive-or (occurrences top-1)
3048	(list occ-1 occ-2)))
3049	(is-false (set-exclusive-or (item-identifiers occ-1)
3050	(list ii-3)))
3051	(is-false (item-identifiers occ-3))
3052	(is-true (d::marked-as-deleted-p name-3))
3053	(is-true (d::marked-as-deleted-p occ-3))))))))))
3054
3055
3056	(test test-merge-constructs-TopicC-2 ()
3057	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3058	(with-fixture with-empty-db (db-dir)
3059	(let ((rev-1 100)
3060	(rev-2 200)
3061	(rev-3 300))
3062	(let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3063	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
3064	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
3065	(sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
3066	(sl-2 (make-construct 'SubjectLocatorC :uri "sl-2"))
3067	(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
3068	(psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
3069	(tid-1 (make-construct 'TopicIdentificationC :uri "tid-1"
3070	:xtm-id "xtm-1"))
3071	(tid-2 (make-construct 'TopicIdentificationC :uri "tid-2"
3072	:xtm-id "xtm-2"))
3073	(type-1 (make-construct 'TopicC :start-revision rev-1))
3074	(type-2 (make-construct 'TopicC :start-revision rev-1))
3075	(theme-1 (make-construct 'TopicC :start-revision rev-1))
3076	(theme-2 (make-construct 'TopicC :start-revision rev-1)))
3077	(let ((variant-1 (make-construct 'VariantC
3078	:start-revision rev-1
3079	:charvalue "var-1"
3080	:themes (list theme-1)))
3081	(variant-2 (make-construct 'VariantC
3082	:start-revision rev-2
3083	:charvalue "var-2"
3084	:themes (list theme-2)))
3085	(variant-3 (make-construct 'VariantC
3086	:start-revision rev-1
3087	:charvalue "var-1"
3088	:themes (list theme-1)))
3089	(occ-1 (make-construct 'OccurrenceC
3090	:start-revision rev-1
3091	:charvalue "occ-1"
3092	:instance-of type-1
3093	:themes (list theme-1)))
3094	(occ-2 (make-construct 'OccurrenceC
3095	:start-revision rev-1
3096	:charvalue "occ-2"
3097	:instance-of type-2))
3098	(occ-3 (make-construct 'OccurrenceC
3099	:start-revision rev-2
3100	:item-identifiers (list ii-3)
3101	:charvalue "occ-1"
3102	:instance-of type-1
3103	:themes (list theme-1))))
3104	(let ((name-1 (make-construct 'NameC
3105	:start-revision rev-1
3106	:charvalue "name-1"
3107	:instance-of type-1))
3108	(name-2 (make-construct 'NameC
3109	:start-revision rev-2
3110	:charvalue "name-2"
3111	:instance-of type-1
3112	:variants (list variant-1 variant-2)))
3113	(name-3 (make-construct 'NameC
3114	:start-revision rev-1
3115	:charvalue "name-1"
3116	:instance-of type-1
3117	:variants (list variant-3))))
3118	(let ((top-1 (make-construct 'TopicC
3119	:start-revision rev-1
3120	:topic-identifiers (list tid-1)
3121	:item-identifiers (list ii-1)
3122	:locators (list sl-1)
3123	:psis (list psi-1)
3124	:names (list name-1 name-2)
3125	:occurrences (list occ-1 occ-2)))
3126	(top-2 (make-construct 'TopicC
3127	:start-revision rev-3
3128	:topic-identifiers (list tid-2)
3129	:item-identifiers (list ii-2)
3130	:locators (list sl-2)
3131	:psis (list psi-2)
3132	:names (list name-3)
3133	:occurrences (list occ-3))))
3134	(setf TM-REVISION rev-3)
3135	(is (= (length (elephant:get-instances-by-class 'TopicC)) 6))
3136	(is (= (length (elephant:get-instances-by-class 'NameC)) 3))
3137	(is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3))
3138	(is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
3139	(let ((top (d::merge-constructs top-1 top-2 :revision rev-3)))
3140	(is (= (length (elephant:get-instances-by-class 'TopicC)) 5))
3141	(is (= (length (elephant:get-instances-by-class 'NameC)) 2))
3142	(is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2))
3143	(is (= (length (elephant:get-instances-by-class 'VariantC)) 3))
3144	(is (eql top top-1))
3145	(is-false (append (psis top-2) (item-identifiers top-2)
3146	(locators top-2) (topic-identifiers top-2)
3147	(names top-2) (occurrences top-2)))
3148	(is-false (set-exclusive-or (list ii-1 ii-2)
3149	(item-identifiers top-1)))
3150	(is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1)))
3151	(is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
3152	(is-false (set-exclusive-or (list tid-1 tid-2)
3153	(topic-identifiers top-1)))
3154	(is-false (set-exclusive-or (list psi-1)
3155	(psis top-1 :revision rev-2)))
3156	(is-false (set-exclusive-or (list name-1 name-2)
3157	(names top-1)))
3158	(is-false (set-exclusive-or (variants name-1)
3159	(list variant-3)))
3160	(is-false (variants name-3))
3161	(is-false (set-exclusive-or (occurrences top-1)
3162	(list occ-1 occ-2)))
3163	(is-false (set-exclusive-or (item-identifiers occ-1)
3164	(list ii-3)))
3165	(is-false (item-identifiers occ-3))
3166	(is-true (d::marked-as-deleted-p name-3))
3167	(is-true (d::marked-as-deleted-p occ-3))))))))))
3168
3169
3170	(test test-merge-constructs-TopicC-3 ()
3171	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3172	(with-fixture with-empty-db (db-dir)
3173	(let ((rev-1 100)
3174	(rev-3 300))
3175	(let ((type-1 (make-construct 'TopicC :start-revision rev-1))
3176	(type-2 (make-construct 'TopicC :start-revision rev-1))
3177	(n-type (make-construct 'TopicC :start-revision rev-1))
3178	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3179	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
3180	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
3181	(ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))
3182	(ii-5 (make-construct 'ItemIdentifierC :uri "ii-5"))
3183	(ii-6 (make-construct 'ItemIdentifierC :uri "ii-6"))
3184	(var-0-1
3185	(make-construct 'VariantC
3186	:start-revision rev-1
3187	:themes (list
3188	(make-construct 'TopicC
3189	:start-revision rev-1))
3190	:charvalue "var-0-1"))
3191	(var-0-2
3192	(make-construct 'VariantC
3193	:start-revision rev-1
3194	:themes (list
3195	(make-construct 'TopicC
3196	:start-revision rev-1))
3197	:charvalue "var-0-1")))
3198	(let ((occ-1 (make-construct 'OccurrenceC
3199	:start-revision rev-1
3200	:item-identifiers (list ii-1)
3201	:charvalue "occ"
3202	:instance-of type-1))
3203	(occ-2 (make-construct 'OccurrenceC
3204	:start-revision rev-1
3205	:item-identifiers (list ii-2)
3206	:charvalue "occ"
3207	:instance-of type-2))
3208	(name-1 (make-construct 'NameC
3209	:start-revision rev-1
3210	:item-identifiers (list ii-3)
3211	:variants (list var-0-1)
3212	:charvalue "name"
3213	:instance-of type-1))
3214	(name-2 (make-construct 'NameC
3215	:start-revision rev-1
3216	:item-identifiers (list ii-4)
3217	:variants (list var-0-2)
3218	:charvalue "name"
3219	:instance-of type-2))
3220	(var-1 (make-construct 'VariantC
3221	:start-revision rev-1
3222	:item-identifiers (list ii-5)
3223	:charvalue "var"
3224	:themes (list type-1)))
3225	(var-2 (make-construct 'VariantC
3226	:start-revision rev-1
3227	:item-identifiers (list ii-6)
3228	:charvalue "var"
3229	:themes (list type-2))))
3230	(let ((top-1 (make-construct 'TopicC
3231	:start-revision rev-1
3232	:occurrences (list occ-1 occ-2)
3233	:names (list name-1 name-2)))
3234	(name-3 (make-construct 'NameC
3235	:start-revision rev-1
3236	:charvalue "name-3"
3237	:instance-of n-type
3238	:variants (list var-1 var-2))))
3239	(let ((top-2 (make-construct 'TopicC
3240	:start-revision rev-1
3241	:names (list name-3))))
3242	(setf TM-REVISION rev-3)
3243	(is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
3244	(is (= (length (occurrences top-1)) 1))
3245	(is-false (set-exclusive-or
3246	(list ii-1 ii-2)
3247	(item-identifiers (first (occurrences top-1)))))
3248	(is (= (length (slot-value top-1 'd::occurrences)) 2))
3249	(is (= (length (names top-1)) 1))
3250	(is-false (set-exclusive-or
3251	(list ii-3 ii-4)
3252	(item-identifiers (first (names top-1)))))
3253	(is (= (length (slot-value top-1 'd::names)) 2))
3254	(is-false (set-exclusive-or (list var-0-1 var-0-2)
3255	(variants (first (names top-1)))))
3256	(is-true (d::marked-as-deleted-p
3257	(find-if-not #'(lambda(occ)
3258	(eql occ (first (occurrences top-1))))
3259	(slot-value top-1 'd::occurrences))))
3260	(is-true (d::marked-as-deleted-p
3261	(find-if-not #'(lambda(name)
3262	(eql name (first (names top-1))))
3263	(slot-value top-1 'd::names))))
3264	(is (= (length (variants (first (names top-2)))) 1))
3265	(is (= (length (slot-value (first (names top-2)) 'd::variants)) 2))
3266	(is (eql (first (themes (first (variants (first (names top-2))))))
3267	type-1)))))))))
3268
3269
3270	(test test-merge-constructs-TopicC-4 ()
3271	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3272	(with-fixture with-empty-db (db-dir)
3273	(let ((rev-1 100)
3274	(rev-3 300))
3275	(let ((type-1 (make-construct 'TopicC :start-revision rev-1))
3276	(type-2 (make-construct 'TopicC :start-revision rev-1))
3277	(a-type (make-construct 'TopicC :start-revision rev-1))
3278	(r-type (make-construct 'TopicC :start-revision rev-1))
3279	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3280	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
3281	(let ((assoc-1 (make-construct 'AssociationC
3282	:start-revision rev-1
3283	:instance-of a-type
3284	:roles (list (list :player type-1
3285	:instance-of r-type
3286	:item-identifiers (list ii-1)
3287	:start-revision rev-1)
3288	(list :player type-2
3289	:item-identifiers (list ii-2)
3290	:instance-of r-type
3291	:start-revision rev-1)))))
3292	(setf TM-REVISION rev-3)
3293	(is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
3294	(is (= (length (roles assoc-1)) 1))
3295	(is (= (length (slot-value assoc-1 'd::roles)) 2))
3296	(is (eql (instance-of (first (roles assoc-1))) r-type))
3297	(is (eql (player (first (roles assoc-1))) type-1))
3298	(is-false (set-exclusive-or (list ii-1 ii-2)
3299	(item-identifiers (first (roles assoc-1)))))
3300	(let ((active-role (first (roles assoc-1)))
3301	(non-active-role
3302	(let ((r-assoc (find-if-not #'(lambda(role)
3303	(eql role (first (roles assoc-1))))
3304	(slot-value assoc-1 'd::roles))))
3305	(when r-assoc
3306	(d::role r-assoc)))))
3307	(is (= (length (d::versions
3308	(first (slot-value active-role 'd::parent)))) 2))
3309	(is (= (length (d::versions
3310	(first (slot-value non-active-role 'd::parent)))) 1))
3311	(is-true (find-if #'(lambda(vi)
3312	(and (= rev-1 (d::start-revision vi))
3313	(= rev-3 (d::end-revision vi))))
3314	(d::versions (first (slot-value non-active-role
3315	'd::parent)))))
3316	(is-true (find-if #'(lambda(vi)
3317	(and (= rev-1 (d::start-revision vi))
3318	(= rev-3 (d::end-revision vi))))
3319	(d::versions (first (slot-value active-role
3320	'd::parent)))))
3321	(is-true (find-if #'(lambda(vi)
3322	(and (= rev-3 (d::start-revision vi))
3323	(= 0 (d::end-revision vi))))
3324	(d::versions (first (slot-value active-role
3325	'd::parent)))))))))))
3326
3327
3328	(test test-merge-constructs-TopicC-5 ()
3329	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3330	(with-fixture with-empty-db (db-dir)
3331	(let ((rev-1 100)
3332	(rev-3 300))
3333	(let ((type-1 (make-construct 'TopicC :start-revision rev-1))
3334	(type-2 (make-construct 'TopicC :start-revision rev-1))
3335	(a-type (make-construct 'TopicC :start-revision rev-1))
3336	(player-1 (make-construct 'TopicC :start-revision rev-1))
3337	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3338	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
3339	(let ((assoc-2 (make-construct 'AssociationC
3340	:start-revision rev-1
3341	:instance-of a-type
3342	:roles (list (list :player player-1
3343	:instance-of type-1
3344	:item-identifiers (list ii-1)
3345	:start-revision rev-1)
3346	(list :player player-1
3347	:item-identifiers (list ii-2)
3348	:instance-of type-2
3349	:start-revision rev-1)))))
3350	(setf TM-REVISION rev-3)
3351	(is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
3352	(is (= (length (roles assoc-2)) 1))
3353	(is (= (length (slot-value assoc-2 'd::roles)) 2))
3354	(is (eql (instance-of (first (roles assoc-2))) type-1))
3355	(is (eql (player (first (roles assoc-2))) player-1))
3356	(is-false (set-exclusive-or (list ii-1 ii-2)
3357	(item-identifiers (first (roles assoc-2)))))
3358	(let ((active-role (first (roles assoc-2)))
3359	(non-active-role
3360	(let ((r-assoc (find-if-not #'(lambda(role)
3361	(eql role (first (roles assoc-2))))
3362	(slot-value assoc-2 'd::roles))))
3363	(when r-assoc
3364	(d::role r-assoc)))))
3365	(is (= (length (d::versions
3366	(first (slot-value active-role 'd::parent)))) 2))
3367	(is (= (length (d::versions
3368	(first (slot-value non-active-role 'd::parent)))) 1))
3369	(is-true (find-if #'(lambda(vi)
3370	(and (= rev-1 (d::start-revision vi))
3371	(= rev-3 (d::end-revision vi))))
3372	(d::versions (first (slot-value non-active-role
3373	'd::parent)))))
3374	(is-true (find-if #'(lambda(vi)
3375	(and (= rev-1 (d::start-revision vi))
3376	(= rev-3 (d::end-revision vi))))
3377	(d::versions (first (slot-value active-role
3378	'd::parent)))))
3379	(is-true (find-if #'(lambda(vi)
3380	(and (= rev-3 (d::start-revision vi))
3381	(= 0 (d::end-revision vi))))
3382	(d::versions (first (slot-value active-role
3383	'd::parent)))))))))))
3384
3385
3386	(test test-merge-constructs-TopicC-6 ()
3387	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3388	(with-fixture with-empty-db (db-dir)
3389	(let ((rev-1 100)
3390	(rev-2 200)
3391	(rev-3 300))
3392	(let ((type-1 (make-construct 'TopicC :start-revision rev-1))
3393	(type-2 (make-construct 'TopicC :start-revision rev-1))
3394	(r-type-1 (make-construct 'TopicC :start-revision rev-1))
3395	(r-type-2 (make-construct 'TopicC :start-revision rev-1))
3396	(player-1 (make-construct 'TopicC :start-revision rev-1))
3397	(player-2 (make-construct 'TopicC :start-revision rev-1))
3398	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3399	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
3400	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
3401	(ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")))
3402	(let ((assoc-3 (make-construct 'AssociationC
3403	:start-revision rev-1
3404	:instance-of type-1
3405	:item-identifiers (list ii-3)
3406	:roles (list (list :player player-1
3407	:instance-of r-type-1
3408	:item-identifiers (list ii-1)
3409	:start-revision rev-1)
3410	(list :player player-2
3411	:instance-of r-type-2
3412	:start-revision rev-1))))
3413	(assoc-4 (make-construct 'AssociationC
3414	:start-revision rev-2
3415	:instance-of type-2
3416	:item-identifiers (list ii-4)
3417	:roles (list (list :player player-1
3418	:instance-of r-type-1
3419	:start-revision rev-2)
3420	(list :player player-2
3421	:item-identifiers (list ii-2)
3422	:instance-of r-type-2
3423	:start-revision rev-2)))))
3424	(setf TM-REVISION rev-3)
3425	(is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1))
3426	(is (= (length (d::versions assoc-3)) 2))
3427	(is (= (length (d::versions assoc-4)) 1))
3428	(is-true (find-if #'(lambda(vi)
3429	(and (= (d::start-revision vi) rev-1)
3430	(= (d::end-revision vi) rev-3)))
3431	(d::versions assoc-3)))
3432	(is-true (find-if #'(lambda(vi)
3433	(and (= (d::start-revision vi) rev-3)
3434	(= (d::end-revision vi) 0)))
3435	(d::versions assoc-3)))
3436	(is-true (find-if #'(lambda(vi)
3437	(and (= (d::start-revision vi) rev-2)
3438	(= (d::end-revision vi) rev-3)))
3439	(d::versions assoc-4)))
3440	(is (= (length (roles assoc-3)) 2))
3441	(is (= (length (item-identifiers (first (roles assoc-3)))) 1))
3442	(is (= (length (item-identifiers (second (roles assoc-3)))) 1))
3443	(is (or (and (string= (uri (first (item-identifiers
3444	(first (roles assoc-3)))))
3445	"ii-1")
3446	(string= (uri (first (item-identifiers
3447	(second (roles assoc-3)))))
3448	"ii-2"))
3449	(and (string= (uri (first (item-identifiers
3450	(first (roles assoc-3)))))
3451	"ii-2")
3452	(string= (uri (first (item-identifiers
3453	(second (roles assoc-3)))))
3454	"ii-1")))))))))
3455
3456
3457	(test test-merge-constructs-TopicC-7 ()
3458	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3459	(with-fixture with-empty-db (db-dir)
3460	(let ((rev-1 100)
3461	(rev-2 200)
3462	(rev-3 300)
3463	(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
3464	(sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
3465	(tid-1 (make-construct 'TopicIdentificationC
3466	:uri "tid-1" :xtm-id "xtm-1"))
3467	(tid-2 (make-construct 'TopicIdentificationC
3468	:uri "tid-2" :xtm-id "xtm-2"))
3469	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3470	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
3471	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")))
3472	(let ((type-1 (make-construct 'TopicC :start-revision rev-1))
3473	(scope-1 (make-construct 'TopicC :start-revision rev-1))
3474	(scope-2 (make-construct 'TopicC :start-revision rev-1))
3475	(top-1 (make-construct 'TopicC
3476	:start-revision rev-1
3477	:psis (list psi-1)
3478	:topic-identifiers (list tid-1)))
3479	(top-2 (make-construct 'TopicC
3480	:start-revision rev-2
3481	:locators (list sl-1)
3482	:topic-identifiers (list tid-2))))
3483	(let ((occ-1 (make-construct 'OccurrenceC
3484	:start-revision rev-1
3485	:item-identifiers (list ii-1)
3486	:instance-of type-1
3487	:themes (list scope-1 scope-2)
3488	:charvalue "occ"
3489	:parent top-1))
3490	(occ-2 (make-construct 'OccurrenceC
3491	:start-revision rev-2
3492	:item-identifiers (list ii-2)
3493	:instance-of type-1
3494	:themes (list scope-1 scope-2)
3495	:charvalue "occ"
3496	:parent top-2))
3497	(occ-3 (make-construct 'OccurrenceC
3498	:start-revision rev-1
3499	:item-identifiers (list ii-3)
3500	:instance-of type-1
3501	:themes (list scope-1)
3502	:charvalue "occ"
3503	:parent top-1)))
3504	(setf TM-REVISION rev-3)
3505	(is (= (length (get-all-topics rev-1)) 4))
3506	(is (= (length (get-all-topics rev-3)) 5))
3507	(is (= (length (d::get-db-instances-by-class
3508	'd::OccurrenceC :revision nil)) 3))
3509	(signals not-mergable-error (add-item-identifier occ-3 ii-1))
3510	(is (eql occ-1 (add-item-identifier occ-1 ii-2)))
3511	(is (= (length (get-all-topics rev-3)) 4))
3512	(is-true (d::marked-as-deleted-p occ-2))
3513	(is-true (d::marked-as-deleted-p top-2))
3514	(is-false (set-exclusive-or (list ii-1 ii-2)
3515	(item-identifiers occ-1)))
3516	(is-false (item-identifiers occ-2))
3517	(is-false (set-exclusive-or (list ii-2)
3518	(item-identifiers occ-2 :revision rev-2)))
3519	(is-false (set-exclusive-or (list psi-1) (psis top-1)))
3520	(is-false (set-exclusive-or (list sl-1) (locators top-1)))
3521	(is-false (set-exclusive-or (list tid-1 tid-2)
3522	(topic-identifiers top-1)))
3523	(is-false (locators top-2)))))))
3524
3525
3526	(test test-merge-constructs-TopicC-8 ()
3527	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3528	(with-fixture with-empty-db (db-dir)
3529	(let ((rev-1 100)
3530	(rev-2 200)
3531	(rev-3 300))
3532	(let ((top-1 (make-construct 'TopicC :start-revision rev-1))
3533	(top-2 (make-construct 'TopicC :start-revision rev-2))
3534	(reifier-1 (make-construct 'TopicC :start-revision rev-1))
3535	(type-1 (make-construct 'TopicC :start-revision rev-1))
3536	(type-2 (make-construct 'TopicC :start-revision rev-1)))
3537	(let ((occ-1 (make-construct 'OccurrenceC
3538	:start-revision rev-1
3539	:instance-of type-1
3540	:charvalue "occ"
3541	:reifier reifier-1
3542	:parent top-1))
3543	(occ-2 (make-construct 'OccurrenceC
3544	:start-revision rev-2
3545	:instance-of type-1
3546	:charvalue "occ"
3547	:parent top-2))
3548	(occ-3 (make-construct 'OccurrenceC
3549	:start-revision rev-1
3550	:instance-of type-2
3551	:charvalue "occ"
3552	:parent top-1)))
3553	(setf TM-REVISION rev-3)
3554	(signals not-mergable-error (add-reifier occ-3 reifier-1))
3555	(is (eql (add-reifier occ-2 reifier-1) occ-1))
3556	(is-false (set-exclusive-or (list occ-1 occ-3) (occurrences top-1)))
3557	(is-true (marked-as-deleted-p top-2))
3558	(is-true (marked-as-deleted-p occ-2))
3559	(is (= (length (d::versions top-1)) 2))
3560	(is (= (length (d::versions top-2)) 1))
3561	(is-true (find-if #'(lambda(vi)
3562	(and (= (d::end-revision vi) rev-3)
3563	(= (d::start-revision vi) rev-1)))
3564	(d::versions top-1)))
3565	(is-true (find-if #'(lambda(vi)
3566	(and (= (d::end-revision vi) 0)
3567	(= (d::start-revision vi) rev-3)))
3568	(d::versions top-1)))
3569	(is-true (find-if #'(lambda(vi)
3570	(and (= (d::end-revision vi) rev-3)
3571	(= (d::start-revision vi) rev-2)))
3572	(d::versions top-2)))
3573	(is (= (length (slot-value occ-2 'd::parent)) 1))
3574	(is (= (length (slot-value occ-1 'd::parent)) 1))
3575	(is-true (find-if #'(lambda(vi)
3576	(and (= (d::end-revision vi) rev-3)
3577	(= (d::start-revision vi) rev-2)))
3578	(first (map 'list #'d::versions
3579	(slot-value occ-2 'd::parent)))))
3580	(is-true (find-if #'(lambda(vi)
3581	(and (= (d::end-revision vi) rev-3)
3582	(= (d::start-revision vi) rev-1)))
3583	(first (map 'list #'d::versions
3584	(slot-value occ-1 'd::parent)))))
3585	(is-true (find-if #'(lambda(vi)
3586	(and (= (d::end-revision vi) 0)
3587	(= (d::start-revision vi) rev-3)))
3588	(first (map 'list #'d::versions
3589	(slot-value occ-1 'd::parent))))))))))
3590
3591
3592	(test test-merge-constructs-TopicC-9 ()
3593	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3594	(with-fixture with-empty-db (db-dir)
3595	(let ((rev-1 100)
3596	(rev-2 200)
3597	(rev-3 300)
3598	(rev-4 400)
3599	(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
3600	(psi-2 (make-construct 'PersistentIdC :uri "psi-2")))
3601	(let ((top-1 (make-construct 'TopicC :start-revision rev-2
3602	:psis (list psi-2)))
3603	(top-2 (make-construct 'TopicC :start-revision rev-2))
3604	(top-3 (make-construct 'TopicC :start-revision rev-1))
3605	(reifier-1 (make-construct 'TopicC :start-revision rev-1))
3606	(reifier-2 (make-construct 'TopicC :start-revision rev-2
3607	:psis (list psi-1)))
3608	(reifier-3 (make-construct 'TopicC :start-revision rev-1))
3609	(reifier-4 (make-construct 'TopicC :start-revision rev-1))
3610	(type-1 (make-construct 'TopicC :start-revision rev-1))
3611	(type-2 (make-construct 'TopicC :start-revision rev-1)))
3612	(let ((occ-1 (make-construct 'OccurrenceC
3613	:start-revision rev-2
3614	:instance-of type-1
3615	:charvalue "occ"
3616	:reifier reifier-1
3617	:parent top-1))
3618	(occ-2 (make-construct 'OccurrenceC
3619	:start-revision rev-2
3620	:instance-of type-2
3621	:charvalue "occ"
3622	:reifier reifier-3
3623	:parent top-2))
3624	(occ-3 (make-construct 'OccurrenceC
3625	:start-revision rev-1
3626	:instance-of type-1
3627	:charvalue "occ"
3628	:reifier reifier-4
3629	:parent top-3)))
3630	(setf TM-REVISION rev-3)
3631	(is (eql (reifier occ-2) reifier-3))
3632	(signals not-mergable-error (add-reifier occ-1 reifier-3))
3633	(is (eql occ-1 (add-reifier occ-1 reifier-2)))
3634	(is-true (marked-as-deleted-p reifier-2))
3635	(is-false (set-exclusive-or (list psi-1) (psis reifier-1)))
3636	(setf TM-REVISION rev-4)
3637	(is (eql (add-reifier occ-1 reifier-4) occ-3))
3638	(is-true (marked-as-deleted-p top-1))
3639	(is-false (marked-as-deleted-p top-3))
3640	(is-false (set-exclusive-or (list psi-2) (psis top-3)))
3641	(is-false (marked-as-deleted-p top-2))
3642	(is-false (set-exclusive-or (list occ-2) (occurrences top-2))))))))
3643
3644
3645
3646	(test test-merge-constructs-TopicC-10 ()
3647	"Tests the generic merge-constructs corresÃŒponding to TopicC."
3648	(with-fixture with-empty-db (db-dir)
3649	(let ((rev-1 100)
3650	(rev-2 200)
3651	(rev-3 300)
3652	(psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
3653	(psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
3654	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3655	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
3656	(ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
3657	(ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")))
3658	(let ((top-1 (make-construct 'TopicC
3659	:start-revision rev-1
3660	:psis (list psi-1)))
3661	(top-2 (make-construct 'TopicC
3662	:start-revision rev-2
3663	:psis (list psi-2)))
3664	(type-1 (make-construct 'TopicC :start-revision rev-1))
3665	(scope-1 (make-construct 'TopicC :start-revision rev-1)))
3666	(let ((name-1 (make-construct 'NameC
3667	:start-revision rev-1
3668	:instance-of nil
3669	:charvalue "name"
3670	:themes (list scope-1)
3671	:item-identifiers (list ii-1)
3672	:parent top-1))
3673	(name-2 (make-construct 'NameC
3674	:start-revision rev-1
3675	:instance-of type-1
3676	:charvalue "name"
3677	:themes (list scope-1)
3678	:parent top-1))
3679	(name-3 (make-construct 'NameC
3680	:start-revision rev-2
3681	:instance-of nil
3682	:charvalue "name"
3683	:themes (list scope-1)
3684	:item-identifiers (list ii-2)
3685	:parent top-2))
3686	(name-4 (make-construct 'NameC
3687	:start-revision rev-2
3688	:instance-of type-1
3689	:charvalue "name"
3690	:themes nil
3691	:parent top-2)))
3692	(let ((variant-1 (make-construct 'VariantC
3693	:start-revision rev-1
3694	:charvalue "variant"
3695	:themes (list scope-1)
3696	:item-identifiers (list ii-3 ii-4)
3697	:parent name-1))
3698	(variant-2 (make-construct 'VariantC
3699	:start-revision rev-1
3700	:charvalue "variant"
3701	:themes (list scope-1)
3702	:parent name-4))
3703	(variant-3 (make-construct 'VariantC
3704	:start-revision rev-2
3705	:charvalue "variant"
3706	:themes (list scope-1)
3707	:parent name-3)))
3708	(setf TM-REVISION rev-3)
3709	(signals not-mergable-error (add-item-identifier variant-2 ii-4))
3710	(is-false (marked-as-deleted-p top-2))
3711	(is-false (marked-as-deleted-p top-1))
3712	(is-false (marked-as-deleted-p name-4))
3713	(is (eql (add-item-identifier variant-3 ii-4) variant-1))
3714	(is-true (marked-as-deleted-p top-2))
3715	(is-false (names top-2))
3716	(is-false (psis top-2))
3717	(is-false (set-exclusive-or (list name-1 name-2 name-4) (names top-1)))
3718	(is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
3719	(is-false (set-exclusive-or (list variant-1) (variants name-1)))
3720	(is-false (set-exclusive-or (list variant-2) (variants name-4)))
3721	(is (= (length (d::versions top-1)) 2))))))))
3722
3723
3724	(test test-merge-constructs-AssociationC ()
3725	"Tests merge-constructs corresponding to AssociationC."
3726	(with-fixture with-empty-db (db-dir)
3727	(let ((rev-1 100)
3728	(rev-2 200)
3729	(rev-3 300))
3730	(let ((type-1 (make-construct 'TopicC :start-revision rev-1))
3731	(r-type-1 (make-construct 'TopicC :start-revision rev-1))
3732	(r-type-2 (make-construct 'TopicC :start-revision rev-1))
3733	(player-1 (make-construct 'TopicC :start-revision rev-1))
3734	(player-2 (make-construct 'TopicC :start-revision rev-1))
3735	(ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
3736	(ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")))
3737	(let ((role-1 (list :start-revision rev-1
3738	:player player-1
3739	:instance-of r-type-1))
3740	(role-2-1 (list :start-revision rev-1
3741	:player player-1
3742	:instance-of r-type-2))
3743	(role-2-2 (list :start-revision rev-2
3744	:player player-1
3745	:item-identifiers (list ii-2)
3746	:instance-of r-type-2))
3747	(role-3 (list :start-revision rev-2
3748	:player player-2
3749	:instance-of r-type-1
3750	:item-identifiers (list ii-1)
3751	:instance-of r-type-2)))
3752	(let ((assoc-1 (make-construct 'AssociationC
3753	:start-revision rev-1
3754	:instance-of type-1
3755	:roles (list role-1 role-2-1)))
3756	(assoc-2 (make-construct 'AssociationC
3757	:start-revision rev-2
3758	:instance-of type-1
3759	:roles (list role-2-2 role-3))))
3760	(setf TM-REVISION rev-3)
3761	(is (= (length (get-all-associations nil)) 2))
3762	(make-construct 'AssociationC
3763	:start-revision rev-2
3764	:instance-of type-1
3765	:roles (list role-1 role-2-1))
3766	(is (= (length (get-all-associations nil)) 2))
3767	(let ((role-2-1-inst
3768	(find-if #'(lambda(role)
3769	(and (eql (instance-of role) r-type-2)
3770	(eql (player role) player-1)))
3771	(roles assoc-1))))
3772	(is-true role-2-1-inst)
3773	(is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst))
3774	(is-true (marked-as-deleted-p assoc-2))
3775	(is-false (roles assoc-2))
3776	(is-false (instance-of assoc-2))
3777	(is-false (themes assoc-2))
3778	(is (eql (instance-of assoc-2 :revision rev-2) type-1))
3779	(is (= (length (roles assoc-1)) 3))
3780	(is-true (find-if #'(lambda(role)
3781	(and (eql (instance-of role) r-type-1)
3782	(eql (player role) player-1)))
3783	(roles assoc-1)))
3784	(is-true (find-if #'(lambda(role)
3785	(and (eql (instance-of role) r-type-1)
3786	(eql (player role) player-2)
3787	(not (set-exclusive-or
3788	(list ii-1)
3789	(item-identifiers role)))))
3790	(roles assoc-1)))
3791	(is-true (find-if #'(lambda(role)
3792	(and (eql (instance-of role) r-type-2)
3793	(eql (player role) player-1)
3794	(not (set-exclusive-or
3795	(list ii-2)
3796	(item-identifiers role)))))
3797	(roles assoc-1))))))))))
3798
3799
3800	(defun run-datamodel-tests()
3801	"Runs all tests of this test-suite."
3802	(it.bese.fiveam:run! 'test-VersionInfoC)
3803	(it.bese.fiveam:run! 'test-VersionedConstructC)
3804	(it.bese.fiveam:run! 'test-ItemIdentifierC)
3805	(it.bese.fiveam:run! 'test-PersistentIdC)
3806	(it.bese.fiveam:run! 'test-SubjectLocatorC)
3807	(it.bese.fiveam:run! 'test-TopicIdentificationC)
3808	(it.bese.fiveam:run! 'test-get-item-by-id)
3809	(it.bese.fiveam:run! 'test-get-item-by-item-identifier)
3810	(it.bese.fiveam:run! 'test-get-item-by-locator)
3811	(it.bese.fiveam:run! 'test-get-item-by-psi)
3812	(it.bese.fiveam:run! 'test-ReifiableConstructC)
3813	(it.bese.fiveam:run! 'test-OccurrenceC)
3814	(it.bese.fiveam:run! 'test-VariantC)
3815	(it.bese.fiveam:run! 'test-NameC)
3816	(it.bese.fiveam:run! 'test-TypableC)
3817	(it.bese.fiveam:run! 'test-ScopableC)
3818	(it.bese.fiveam:run! 'test-RoleC)
3819	(it.bese.fiveam:run! 'test-player)
3820	(it.bese.fiveam:run! 'test-TopicMapC)
3821	(it.bese.fiveam:run! 'test-delete-ItemIdentifierC)
3822	(it.bese.fiveam:run! 'test-delete-PersistentIdC)
3823	(it.bese.fiveam:run! 'test-delete-SubjectLocatorC)
3824	(it.bese.fiveam:run! 'test-delete-ReifiableConstructC)
3825	(it.bese.fiveam:run! 'test-delete-VariantC)
3826	(it.bese.fiveam:run! 'test-delete-NameC)
3827	(it.bese.fiveam:run! 'test-delete-OccurrenceC)
3828	(it.bese.fiveam:run! 'test-delete-TypableC)
3829	(it.bese.fiveam:run! 'test-delete-ScopableC)
3830	(it.bese.fiveam:run! 'test-delete-AssociationC)
3831	(it.bese.fiveam:run! 'test-delete-RoleC)
3832	(it.bese.fiveam:run! 'test-equivalent-PointerC)
3833	(it.bese.fiveam:run! 'test-equivalent-OccurrenceC)
3834	(it.bese.fiveam:run! 'test-equivalent-NameC)
3835	(it.bese.fiveam:run! 'test-equivalent-VariantC)
3836	(it.bese.fiveam:run! 'test-equivalent-RoleC)
3837	(it.bese.fiveam:run! 'test-equivalent-AssociationC)
3838	(it.bese.fiveam:run! 'test-equivalent-TopicC)
3839	(it.bese.fiveam:run! 'test-equivalent-TopicMapC)
3840	(it.bese.fiveam:run! 'test-class-p)
3841	(it.bese.fiveam:run! 'test-find-item-by-revision)
3842	(it.bese.fiveam:run! 'test-make-Unknown)
3843	(it.bese.fiveam:run! 'test-make-VersionedConstructC)
3844	(it.bese.fiveam:run! 'test-make-TopicIdentificationC)
3845	(it.bese.fiveam:run! 'test-make-PersistentIdC)
3846	(it.bese.fiveam:run! 'test-make-SubjectLocatorC)
3847	(it.bese.fiveam:run! 'test-make-ItemIdentifierC)
3848	(it.bese.fiveam:run! 'test-make-OccurrenceC)
3849	(it.bese.fiveam:run! 'test-make-NameC)
3850	(it.bese.fiveam:run! 'test-make-VariantC)
3851	(it.bese.fiveam:run! 'test-make-RoleC)
3852	(it.bese.fiveam:run! 'test-make-TopicMapC)
3853	(it.bese.fiveam:run! 'test-make-AssociationC)
3854	(it.bese.fiveam:run! 'test-make-TopicC)
3855	(it.bese.fiveam:run! 'test-find-oldest-construct)
3856	(it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
3857	(it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
3858	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-1)
3859	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-2)
3860	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-3)
3861	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-4)
3862	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-5)
3863	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-6)
3864	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-7)
3865	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
3866	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-9)
3867	(it.bese.fiveam:run! 'test-merge-constructs-TopicC-10)
3868	(it.bese.fiveam:run! 'test-merge-constructs-AssociationC))

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: branches/new-datamodel/src/unit_tests/datamodel_test.lisp

Download in other formats: