Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

datamodel_test.lisp

Last change on this file was 384, checked in by lgiessmann, 13 years ago
code-maintenance: replaced some code sections by functions of base-tools; removed some "hacks" in the code
File size: 152.6 KB

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

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

Context Navigation

source: trunk/src/unit_tests/datamodel_test.lisp

Download in other formats: