Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

datamodel.lisp

Last change on this file was 895, checked in by lgiessmann, 13 years ago
jtm-delete-interface: changed the implementation of the delete interface => not the constructs that will be deleted won't instantiated before te actual delete operation is invoked
Property svn:eol-style set to `native`
File size: 178.0 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
11	(:use :cl :elephant :constants :base-tools)
12	(:nicknames :d)
13	(:import-from :exceptions
14	duplicate-identifier-error
15	object-not-found-error
16	missing-argument-error
17	not-mergable-error
18	tm-reference-error
19	bad-type-error)
20	(:import-from :constants
21	xml-string
22	instance-psi)
23	(:export ;;classes
24	:TopicMapConstructC
25	:VersionedConstructC
26	:ReifiableConstructC
27	:ScopableC
28	:TypableC
29	:TopicMapC
30	:AssociationC
31	:RoleC
32	:CharacteristicC
33	:OccurrenceC
34	:NameC
35	:VariantC
36	:PointerC
37	:IdentifierC
38	:PersistentIdC
39	:ItemIdentifierC
40	:SubjectLocatorC
41	:TopicIdentificationC
42	:TopicC
43	:FragmentC
44
45	;;methods, functions and macros
46	:instanceOf-association-p
47	:has-identifier
48	:get-all-identifiers-of-construct
49	:xtm-id
50	:uri
51	:identified-construct
52	:item-identifiers
53	:add-item-identifier
54	:delete-item-identifier
55	:reifier
56	:add-reifier
57	:delete-reifier
58	:find-item-by-revision
59	:find-most-recent-revision
60	:themes
61	:add-theme
62	:delete-theme
63	:instance-of
64	:add-type
65	:delete-type
66	:parent
67	:add-parent
68	:delete-parent
69	:variants
70	:add-variant
71	:delete-variant
72	:player
73	:add-player
74	:delete-player
75	:roles
76	:add-role
77	:delete-role
78	:associations
79	:topics
80	:add-to-tm
81	:delete-from-tm
82	:psis
83	:add-psi
84	:delete-psi
85	:topic-identifiers
86	:add-topic-identifier
87	:delete-topic-identifier
88	:topic-id
89	:locators
90	:add-locator
91	:delete-locator
92	:names
93	:add-name
94	:delete-name
95	:occurrences
96	:add-occurrence
97	:delete-occurrence
98	:player-in-roles
99	:used-as-type
100	:used-as-theme
101	:datatype
102	:charvalue
103	:reified-construct
104	:mark-as-deleted
105	:marked-as-deleted-p
106	:in-topicmaps
107	:delete-construct
108	:get-revision
109	:get-item-by-id
110	:get-item-by-psi
111	:get-item-by-item-identifier
112	:get-item-by-locator
113	:get-item-by-content
114	:get-item-by-any-id
115	:any-id
116	:string-integer-p
117	:with-revision
118	:get-latest-fragment-of-topic
119	:create-latest-fragment-of-topic
120	:PointerC-p
121	:IdentifierC-p
122	:SubjectLocatorC-p
123	:PersistentIdC-p
124	:ItemIdentifierC-p
125	:TopicIdentificationC-p
126	:CharacteristicC-p
127	:OccurrenceC-p
128	:NameC-p
129	:VariantC-p
130	:ScopableC-p
131	:TypableC-p
132	:TopicC-p
133	:AssociationC-p
134	:RoleC-p
135	:TopicMapC-p
136	:ReifiableConstructC-p
137	:TopicMapConstructC-p
138	:VersionedConstructC-p
139	:make-construct
140	:list-instanceOf
141	:list-super-types
142	:in-topicmap
143	:get-fragments
144	:get-fragment
145	:get-all-revisions
146	:unique-id
147	:topic
148	:referenced-topics
149	:revision
150	:get-all-revisions-for-tm
151	:add-source-locator
152	:changed-p
153	:check-for-duplicate-identifiers
154	:find-item-by-content
155	:rec-remf
156	:get-all-topics
157	:get-all-associations
158	:get-all-roles
159	:get-all-occurrences
160	:get-all-names
161	:get-all-variants
162	:get-all-tms
163
164	;;globals
165	:TM-REVISION
166	:CURRENT-XTM
167
168	;;trivial-queries
169	:roles-by-type
170	:roles-by-player
171	:filter-associations-by-type
172	:filter-associations-by-role
173	:associations-of
174	:instance-of-associations
175	:supertype-associations
176	:direct-supertypes
177	:supertypes
178	:direct-instance-of
179	:invoke-on
180	:names-by-type
181	:occurrences-by-type
182	:occurrences-by-datatype
183	:characteristics-by-type
184	:occurrences-by-value
185	:names-by-value
186	:characteristics-by-value
187	:filter-type-instance-topics
188	:isa
189	:aka))
190
191	(in-package :datamodel)
192
193
194	;;TODO: implement a macro with-merge-constructs, that merges constructs
195	;; after all operations in the body were called
196
197
198
199	;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
200	(defvar TM-REVISION 0)
201
202
203	(defparameter CURRENT-XTM nil "Represents the currently active TM.")
204
205
206	;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
207	;;; versioning
208	(defpclass VersionInfoC()
209	((start-revision :initarg :start-revision
210	:accessor start-revision
211	:type integer
212	:initform 0
213	:documentation "The start-revision of the version's
214	interval of a versioned object.")
215	(end-revision :initarg :end-revision
216	:accessor end-revision
217	:type integer
218	:initform 0
219	:documentation "The end-revision of the version's interval
220	of a versioned object.")
221	(versioned-construct :initarg :versioned-construct
222	:accessor versioned-construct
223	:associate VersionedConstructC
224	:documentation "The reference of the versioned
225	object that is described by this
226	VersionInfoC-object."))
227	(:documentation "A VersionInfoC-object describes the revision information
228	of a versioned object in intervals starting by the value
229	start-revision and ending by the value end-revision - 1.
230	end-revision=0 means always the latest version."))
231
232
233	(defpclass VersionedConstructC()
234	((versions :initarg :versions
235	:accessor versions
236	:inherit t
237	:associate (VersionInfoC versioned-construct)
238	:documentation "Version infos for former versions of this base
239	class.")))
240
241
242	;;; base classes ...
243	(defpclass TopicMapConstructC()
244	()
245	(:documentation "An abstract base class for all classes that describes
246	Topic Maps data."))
247
248
249	(defpclass ScopableC()
250	((themes :associate (ScopeAssociationC scopable-construct)
251	:inherit t
252	:documentation "Contains all association-objects that contain the
253	actual scope-topics."))
254	(:documentation "An abstract base class for all constructs that are scoped."))
255
256
257	(defpclass TypableC()
258	((instance-of :associate (TypeAssociationC typable-construct)
259	:inherit t
260	:documentation "Contains all association-objects that contain
261	the actual type-topic."))
262	(:documentation "An abstract base class for all typed constructcs."))
263
264
265	(defpclass DatatypableC()
266	((datatype :accessor datatype
267	:initarg :datatype
268	:initform constants:xml-string
269	:type string
270	:index t
271	:documentation "The XML Schema datatype of the occurrencevalue
272	(optional, always IRI for resourceRef)."))
273	(:documentation "An abstract base class for characteristics that own
274	an xml-datatype."))
275
276
277	;;; pointers ...
278	(defpclass PointerC(TopicMapConstructC)
279	((uri :initarg :uri
280	:accessor uri
281	:inherit t
282	:type string
283	:initform (error (make-missing-argument-condition "From PointerC(): uri must be set for a pointer" 'uri ':uri))
284	:index t
285	:documentation "The actual value of a pointer, i.e. uri or ID.")
286	(identified-construct :associate (PointerAssociationC identifier)
287	:inherit t
288	:documentation "Associates a association-object that
289	additionally stores some
290	version-infos."))
291	(:documentation "An abstract base class for all pointers."))
292
293
294	(defpclass TopicIdentificationC(PointerC)
295	((xtm-id :initarg :xtm-id
296	:accessor xtm-id
297	:type string
298	:initform (error (make-missing-argument-condition "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier" 'xtm-id ':xtm-id))
299	:index t
300	:documentation "ID of the TM this identification came from."))
301	(:index t)
302	(:documentation "Identify topic items through generalized topic-ids.
303	A topic may have many original topicids, the class
304	representing one of them."))
305
306
307	(defpclass IdentifierC(PointerC)
308	()
309	(:documentation "An abstract base class for all TM-Identifiers."))
310
311
312	(defpclass SubjectLocatorC(IdentifierC)
313	()
314	(:index t)
315	(:documentation "A subject-locator that contains an uri-value and an
316	association to SubjectLocatorAssociationC's which are in
317	turn associated with TopicC's."))
318
319
320	(defpclass PersistentIdC(IdentifierC)
321	()
322	(:index t)
323	(:documentation "A subject-identifier that contains an uri-value and an
324	association to PersistentIdAssociationC's which are in
325	turn associated with TopicC's."))
326
327
328	(defpclass ItemIdentifierC(IdentifierC)
329	()
330	(:index t)
331	(:documentation "An item-identifier that contains an uri-value and an
332	association to ItemIdAssociationC's which are in turn
333	associated with RiefiableConstructC's."))
334
335
336	;;; reifiables ...
337	(defpclass ReifiableConstructC(TopicMapConstructC)
338	((item-identifiers :associate (ItemIdAssociationC parent-construct)
339	:inherit t
340	:documentation "A relation to all item-identifiers of
341	this construct.")
342	(reifier :associate (ReifierAssociationC reifiable-construct)
343	:inherit t
344	:documentation "A relation to a reifier-topic."))
345	(:documentation "Reifiable constructs as per TMDM."))
346
347
348	(defpclass AssociationC(ReifiableConstructC ScopableC TypableC
349	VersionedConstructC)
350	((roles :associate (RoleAssociationC parent-construct)
351	:documentation "Contains all association-objects of all roles this
352	association contains.")
353	(in-topicmaps :associate (TopicMapC associations)
354	:many-to-many t
355	:documentation "List of all topic maps this association is
356	part of"))
357	(:index t)
358	(:documentation "Association in a Topic Map"))
359
360
361	(defpclass RoleC(ReifiableConstructC TypableC)
362	((parent :associate (RoleAssociationC role)
363	:documentation "Associates this object with a role-association.")
364	(player :associate (PlayerAssociationC parent-construct)
365	:documentation "Associates this object with a player-association.")))
366
367
368	(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC)
369	((topics :associate (TopicC in-topicmaps)
370	:many-to-many t
371	:accessor topics
372	:documentation "List of topics that explicitly belong to this TM.")
373	(associations :associate (AssociationC in-topicmaps)
374	:many-to-many t
375	:accessor associations
376	:documentation "List of associations that belong to this TM."))
377	(:documentation "Represnets a topic map."))
378
379
380	(defpclass TopicC (ReifiableConstructC VersionedConstructC)
381	((topic-identifiers :associate (TopicIdAssociationC parent-construct)
382	:documentation "Contains all association objects that
383	relate a topic with its actual
384	topic-identifiers.")
385	(psis :associate (PersistentIdAssociationC parent-construct)
386	:documentation "Contains all association objects that relate a topic
387	with its actual psis.")
388	(locators :associate (SubjectLocatorAssociationC parent-construct)
389	:documentation "Contains all association objects that relate a
390	topic with its actual subject-lcoators.")
391	(names :associate (NameAssociationC parent-construct)
392	:documentation "Contains all association objects that relate a topic
393	with its actual names.")
394	(occurrences :associate (OccurrenceAssociationC parent-construct)
395	:documentation "Contains all association objects that relate a
396	topic with its actual occurrences.")
397	(player-in-roles :associate (PlayerAssociationC player-topic)
398	:documentation "Contains all association objects that relate
399	a topic that is a player with its role.")
400	(used-as-type :associate (TypeAssociationC type-topic)
401	:documentation "Contains all association objects that relate a
402	topic that is a type with its typable obejct.")
403	(used-as-theme :associate (ScopeAssociationC theme-topic)
404	:documentation "Contains all association objects that relate a
405	topic that is a theme with its scoppable
406	object.")
407	(reified-construct :associate (ReifierAssociationC reifier-topic)
408	:documentation "Contains all association objects that
409	relate a topic that is a reifier with
410	its reified object.")
411	(in-topicmaps :associate (TopicMapC topics)
412	:many-to-many t
413	:documentation "List of all topic maps this topic is part of."))
414	(:index t)
415	(:documentation "Represents a TM topic."))
416
417
418
419	;;; characteristics ...
420	(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC)
421	((parent :associate (CharacteristicAssociationC characteristic)
422	:inherit t
423	:documentation "Assocates the characterist obejct with the
424	parent-association.")
425	(charvalue :initarg :charvalue
426	:accessor charvalue
427	:type string
428	:inherit t
429	:initform ""
430	:index t
431	:documentation "Contains the actual data of this object."))
432	(:documentation "Scoped characteristic of a topic (meant to be used
433	as an abstract class)."))
434
435
436	(defpclass OccurrenceC(CharacteristicC DatatypableC)
437	()
438	(:documentation "Represents a TM occurrence."))
439
440
441	(defpclass NameC(CharacteristicC)
442	((variants :associate (VariantAssociationC parent-construct)
443	:documentation "Associates this obejct with varian-associations."))
444	(:documentation "Scoped name of a topic."))
445
446
447	(defpclass VariantC(CharacteristicC DatatypableC)
448	()
449	(:documentation "Represents a TM variant."))
450
451
452	;;; versioned associations ...
453	(defpclass VersionedAssociationC(VersionedConstructC)
454	()
455	(:documentation "An abstract base class for all versioned associations."))
456
457
458	(defpclass TypeAssociationC(VersionedAssociationC)
459	((type-topic :initarg :type-topic
460	:accessor type-topic
461	:initform (error (make-missing-argument-condition "From TypeAssociationC(): type-topic must be set" 'type-topic ':type-topic))
462	:associate TopicC
463	:documentation "Associates this object with a topic that is used
464	as type.")
465	(typable-construct :initarg :typable-construct
466	:accessor typable-construct
467	:initform (error (make-missing-argument-condition "From TypeAssociationC(): typable-construct must be set" 'typable-construct ':typable-construct))
468	:associate TypableC
469	:documentation "Associates this object with the typable
470	construct that is typed by the
471	type-topic."))
472	(:documentation "This class associates topics that are used as type for
473	typable constructcs. Additionally there are stored some
474	version-infos."))
475
476
477	(defpclass ScopeAssociationC(VersionedAssociationC)
478	((theme-topic :initarg :theme-topic
479	:accessor theme-topic
480	:initform (error (make-missing-argument-condition "From ScopeAssociationC(): theme-topic must be set" 'theme-topic ':theme-topic))
481	:associate TopicC
482	:documentation "Associates this opbject with a topic that is a
483	scopable construct.")
484	(scopable-construct :initarg :scopable-construct
485	:accessor scopable-construct
486	:initform (error (make-missing-argument-condition "From ScopeAssociationC(): scopable-construct must be set" 'scopable-construct ':scopable-construct))
487	:associate ScopableC
488	:documentation "Associates this object with the socpable
489	construct that is scoped by the
490	scope-topic."))
491	(:documentation "This class associates topics that are used as scope with
492	scopable construtcs. Additionally there are stored some
493	version-infos"))
494
495
496	(defpclass ReifierAssociationC(VersionedAssociationC)
497	((reifiable-construct :initarg :reifiable-construct
498	:accessor reifiable-construct
499	:initform (error (make-missing-argument-condition "From ReifierAssociation(): reifiable-construct must be set" 'reifiable-construct ':reifiable-construct))
500	:associate ReifiableConstructC
501	:documentation "The actual construct which is reified
502	by a topic.")
503	(reifier-topic :initarg :reifier-topic
504	:accessor reifier-topic
505	:initform (error (make-missing-argument-condition "From ReifierAssociationC(): reifier-topic must be set" 'reifier-topic ':reifier-topic))
506	:associate TopicC
507	:documentation "The reifier-topic that reifies the
508	reifiable-construct."))
509	(:documentation "A versioned-association that relates a reifiable-construct
510	with a topic."))
511
512
513	;;; pointer associations ...
514	(defpclass PointerAssociationC (VersionedAssociationC)
515	((identifier :initarg :identifier
516	:accessor identifier
517	:inherit t
518	:initform (error (make-missing-argument-condition "From PointerAssociationC(): identifier must be set" 'identifier ':identifier))
519	:associate PointerC
520	:documentation "The actual data that is associated with
521	the pointer-association's parent."))
522	(:documentation "An abstract base class for all versioned
523	pointer-associations."))
524
525
526	(defpclass SubjectLocatorAssociationC(PointerAssociationC)
527	((parent-construct :initarg :parent-construct
528	:accessor parent-construct
529	:initform (error (make-missing-argument-condition "From SubjectLocatorAssociationC(): parent-construct must be set" 'parent-construct ':parent-symbol))
530	:associate TopicC
531	:documentation "The actual topic which is associated
532	with the subject-locator."))
533	(:documentation "A pointer that associates subject-locators, versions
534	and topics."))
535
536
537	(defpclass PersistentIdAssociationC(PointerAssociationC)
538	((parent-construct :initarg :parent-construct
539	:accessor parent-construct
540	:initform (error (make-missing-argument-condition "From PersistentIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
541	:associate TopicC
542	:documentation "The actual topic which is associated
543	with the subject-identifier/psi."))
544	(:documentation "A pointer that associates subject-identifiers, versions
545	and topics."))
546
547
548	(defpclass TopicIdAssociationC(PointerAssociationC)
549	((parent-construct :initarg :parent-construct
550	:accessor parent-construct
551	:initform (error (make-missing-argument-condition "From TopicIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
552	:associate TopicC
553	:documentation "The actual topic which is associated
554	with the topic-identifier."))
555	(:documentation "A pointer that associates topic-identifiers, versions
556	and topics."))
557
558
559	(defpclass ItemIdAssociationC(PointerAssociationC)
560	((parent-construct :initarg :parent-construct
561	:accessor parent-construct
562	:initform (error (make-missing-argument-condition "From ItemIdAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
563	:associate ReifiableConstructC
564	:documentation "The actual parent which is associated
565	with the item-identifier."))
566	(:documentation "A pointer that associates item-identifiers, versions
567	and reifiable-constructs."))
568
569
570	;;; characteristic associations ...
571	(defpclass CharacteristicAssociationC(VersionedAssociationC)
572	((characteristic :initarg :characteristic
573	:accessor characteristic
574	:inherit t
575	:initform (error (make-missing-argument-condition "From CharacteristicCAssociation(): characteristic must be set" 'characteristic ':characteristic))
576	:associate CharacteristicC
577	:documentation "Associates this object with the actual
578	characteristic object."))
579	(:documentation "An abstract base class for all association-objects that
580	associates characteristics with topics."))
581
582
583	(defpclass VariantAssociationC(CharacteristicAssociationC)
584	((parent-construct :initarg :parent-construct
585	:accessor parent-construct
586	:initform (error (make-missing-argument-condition "From VariantAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
587	:associate NameC
588	:documentation "Associates this object with a name."))
589	(:documentation "Associates variant objects with name obejcts.
590	Additionally version-infos are stored."))
591
592
593	(defpclass NameAssociationC(CharacteristicAssociationC)
594	((parent-construct :initarg :parent-construct
595	:accessor parent-construct
596	:initform (error (make-missing-argument-condition "From NameAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
597	:associate TopicC
598	:documentation "Associates this object with a topic."))
599	(:documentation "Associates name objects with their parent topics.
600	Additionally version-infos are stored."))
601
602
603	(defpclass OccurrenceAssociationC(CharacteristicAssociationC)
604	((parent-construct :initarg :parent-construct
605	:accessor parent-construct
606	:initform (error (make-missing-argument-condition "From OccurrenceAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
607	:associate TopicC
608	:documentation "Associates this object with a topic."))
609	(:documentation "Associates occurrence objects with their parent topics.
610	Additionally version-infos are stored."))
611
612
613	;;; roles/association associations ...
614	(defpclass PlayerAssociationC(VersionedAssociationC)
615	((player-topic :initarg :player-topic
616	:accessor player-topic
617	:associate TopicC
618	:initform (error (make-missing-argument-condition "From PlayerAssociationC(): player-topic must be set" 'player-topic ':player-topic))
619	:documentation "Associates this object with a topic that is
620	a player.")
621	(parent-construct :initarg :parent-construct
622	:accessor parent-construct
623	:associate RoleC
624	:initform (error (make-missing-argument-condition "From PlayerAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
625	:documentation "Associates this object with the parent-association."))
626	(:documentation "This class associates roles and their player in given
627	revisions."))
628
629
630	(defpclass RoleAssociationC(VersionedAssociationC)
631	((role :initarg :role
632	:accessor role
633	:associate RoleC
634	:initform (error (make-missing-argument-condition "From RoleAssociationC(): role must be set" 'role ':role))
635	:documentation "Associates this objetc with a role-object.")
636	(parent-construct :initarg :parent-construct
637	:accessor parent-construct
638	:associate AssociationC
639	:initform (error (make-missing-argument-condition "From RoleAssociationC(): parent-construct must be set" 'parent-construct ':parent-construct))
640	:documentation "Assocates thius object with an
641	association-object."))
642	(:documentation "Associates roles with assoications and adds some
643	version-infos between these realtions."))
644
645
646	;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
647	(defun make-duplicate-identifier-condition (message uri)
648	"Returns an duplicate-identifier-condition with the passed arguments."
649	(make-condition 'duplicate-identifier-error
650	:message message
651	:uri uri))
652
653
654	(defun make-object-not-found-condition (message)
655	"Returns an object-not-found-condition with the passed arguments."
656	(make-condition 'object-not-found-error
657	:message message))
658
659
660	(defun make-tm-reference-condition (message referenced-construct
661	existing-reference new-reference)
662	"Returns a tm-reference-condition with the passed arguments."
663	(make-condition 'tm-reference-error
664	:message message
665	:referenced-construct referenced-construct
666	:existing-reference existing-reference
667	:new-reference new-reference))
668
669
670	(defun make-bad-type-condition (message expected-type result-object)
671	(make-condition
672	'bad-type-error
673	:message message
674	:expected-type expected-type
675	:result-object result-object))
676
677
678	(defun make-not-mergable-condition (message construct-1 construct-2)
679	"Returns a not-mergable-condition with the passed arguments."
680	(make-condition 'not-mergable-error
681	:message message
682	:construct-1 construct-1
683	:construct-2 construct-2))
684
685
686	(defun make-missing-argument-condition (message argument-symbol function-symbol)
687	"Returns a missing-argument-condition with the passed arguments."
688	(make-condition 'missing-argument-error
689	:message message
690	:argument-symbol argument-symbol
691	:function-symbol function-symbol))
692
693
694	(defgeneric has-identifier (construct uri &key revision)
695	(:documentation "Returns an identifier if there is any identifier bound
696	to the passed construct with the specified uri.")
697	(:method ((construct TopicMapConstructC) (uri String)
698	&key (revision TM-REVISION))
699	(let ((all-ids
700	(get-all-identifiers-of-construct construct :revision revision)))
701	(find-if #'(lambda(idc)
702	(string= (uri idc) uri))
703	all-ids))))
704
705
706	(defgeneric get-most-recent-versioned-assoc (construct slot-symbol)
707	(:documentation "Returns the most recent VersionedAssociationC
708	object.")
709	(:method ((construct TopicMapConstructC) (slot-symbol Symbol))
710	(let ((all-assocs (slot-p construct slot-symbol)))
711	(let ((zero-assoc
712	(find-if #'(lambda(assoc)
713	(= (end-revision
714	(get-most-recent-version-info assoc)) 0))
715	all-assocs)))
716	(if zero-assoc
717	zero-assoc
718	(let ((ordered-assocs
719	(sort all-assocs
720	#'(lambda(x y)
721	(> (end-revision
722	(get-most-recent-version-info x))
723	(end-revision
724	(get-most-recent-version-info y)))))))
725	(when ordered-assocs
726	(first ordered-assocs))))))))
727
728
729	(defun get-latest-topic-by-psi (topic-psi)
730	"Returns the latest topic bound to the PersistentIdC
731	object corresponding to the given uri."
732	(declare (String topic-psi))
733	(let ((psi-inst
734	(elephant:get-instance-by-value
735	'PersistentIdC 'uri topic-psi)))
736	(when psi-inst
737	(let ((latest-va
738	(get-most-recent-versioned-assoc
739	psi-inst 'identified-construct)))
740	(when (and latest-va (versions latest-va))
741	(identified-construct
742	psi-inst :revision (start-revision (first (versions latest-va)))))))))
743
744
745	(defun get-db-instances-by-class (class-symbol &key (revision TM-REVISION))
746	"Returns all instances of the given type and the given revision that are
747	stored in the db."
748	(declare (symbol class-symbol) (type (or null integer) revision))
749	(let ((db-instances (elephant:get-instances-by-class class-symbol)))
750	(let ((filtered-instances (remove-if-not #'(lambda(inst)
751	(typep inst class-symbol))
752	db-instances)))
753	(if revision
754	(remove-null
755	(map 'list #'(lambda(inst)
756	(if (or (typep inst 'CharacteristicC)
757	(typep inst 'RoleC))
758	(find-item-by-revision inst revision
759	(parent inst :revision revision))
760	(find-item-by-revision inst revision)))
761	filtered-instances))
762	filtered-instances))))
763
764
765	(defun get-all-topics (&optional (revision TM-REVISION))
766	(get-db-instances-by-class 'TopicC :revision revision))
767
768
769	(defun get-all-associations (&optional (revision TM-REVISION))
770	(get-db-instances-by-class 'AssociationC :revision revision))
771
772
773	(defun get-all-roles (&optional (revision TM-REVISION))
774	(get-db-instances-by-class 'RoleC :revision revision))
775
776
777	(defun get-all-occurrences (&optional (revision TM-REVISION))
778	(get-db-instances-by-class 'OccurrenceC :revision revision))
779
780
781	(defun get-all-names (&optional (revision TM-REVISION))
782	(get-db-instances-by-class 'NameC :revision revision))
783
784
785	(defun get-all-variants (&optional (revision TM-REVISION))
786	(get-db-instances-by-class 'VariantC :revision revision))
787
788
789	(defun get-all-tms (&optional (revision TM-REVISION))
790	(get-db-instances-by-class 'TopicMapC :revision revision))
791
792
793	(defun find-version-info (versioned-constructs
794	&key (sort-function #'<) (sort-key 'start-revision))
795	"Returns all version-infos sorted by the function sort-function which is
796	applied on the slot sort-key."
797	(declare (list versioned-constructs))
798	(let ((vis
799	(sort
800	(loop for vc in versioned-constructs
801	append (versions vc))
802	sort-function :key sort-key)))
803	(when vis
804	(first vis))))
805
806
807	(defun rec-remf (plist keyword)
808	"Calls remf for the past plist with the given keyword until
809	all key-value-pairs corresponding to the passed keyword were removed."
810	(declare (list plist) (keyword keyword))
811	(loop while (getf plist keyword)
812	do (remf plist keyword))
813	plist)
814
815
816	(defun get-item-by-content (content &key (revision TM-REVISION))
817	"Finds characteristics by their (atomic) content."
818	(let ((constructs
819	(nconc (elephant:get-instances-by-value 'NameC 'Charvalue content)
820	(elephant:get-instances-by-value 'OccurrenceC 'Charvalue content)
821	(elephant:get-instances-by-value 'VariantC 'Charvalue content))))
822	(first
823	(remove-if
824	#'(lambda(construct)
825	(or (string/= (charvalue construct) content)
826	(not (find-item-by-revision construct revision
827	(parent construct :revision revision)))))
828	constructs))))
829
830
831	(defmacro with-revision (revision &rest body)
832	`(let
833	((TM-REVISION ,revision))
834	,@body))
835
836
837	(defun slot-p (instance slot-symbol)
838	"Returns t if the slot depending on slot-symbol is bound and not nil."
839	(if (slot-boundp instance slot-symbol)
840	(let ((value (slot-value instance slot-symbol)))
841	(when value
842	value))
843	;elephant-relations are handled separately, since slot-boundp does not
844	;work here
845	(handler-case (let ((value (slot-value instance slot-symbol)))
846	(when value
847	value))
848	(error () nil))))
849
850
851	(defun delete-1-n-association(instance slot-symbol)
852	(when (slot-p instance slot-symbol)
853	(remove-association
854	instance slot-symbol (slot-value instance slot-symbol))))
855
856
857	(defgeneric delete-construct (construct)
858	(:documentation "Drops recursively construct and all its dependent objects
859	from the elephant store."))
860
861
862	(defmethod delete-construct ((construct elephant:persistent))
863	nil)
864
865
866	(defmethod delete-construct :after ((construct elephant:persistent))
867	(drop-instance construct))
868
869
870	(defun filter-slot-value-by-revision (construct slot-symbol
871	&key (start-revision
872	0 start-revision-provided-p))
873	(declare (symbol slot-symbol) (integer start-revision))
874	(let ((revision
875	(cond (start-revision-provided-p
876	start-revision)
877	((boundp 'TM-REVISION)
878	TM-REVISION)
879	(t 0)))
880	(properties (slot-p construct slot-symbol)))
881	(cond ((not properties)
882	nil) ;no properties were found -> nil
883	((= 0 revision)
884	(remove-if #'null
885	(map 'list #'find-most-recent-revision properties)))
886	(t
887	(remove-if #'null
888	(map 'list #'(lambda(prop)
889	(find-item-by-revision prop revision))
890	properties))))))
891
892
893	(defun get-revision ()
894	"TODO: replace by something that does not suffer from a 1 second resolution."
895	(get-universal-time))
896
897
898	(defun string-integer-p (integer-as-string)
899	"Returns t if the passed string can be parsed to an integer."
900	(handler-case (when (parse-integer integer-as-string)
901	t)
902	(condition () nil)))
903
904
905	(defun merge-all-constructs(constructs-to-be-merged &key (revision TM-REVISION))
906	"Merges all constructs contained in the given list."
907	(declare (list constructs-to-be-merged))
908	(cond ((null constructs-to-be-merged)
909	nil)
910	((= (length constructs-to-be-merged) 1)
911	(first constructs-to-be-merged))
912	(t
913	(let ((constr-1 (first constructs-to-be-merged))
914	(constr-2 (second constructs-to-be-merged))
915	(tail (subseq constructs-to-be-merged 2)))
916	(let ((merged-constr
917	(merge-constructs constr-1 constr-2 :revision revision)))
918	(merge-all-constructs (append (list merged-constr)
919	tail)))))))
920
921
922	(defgeneric internal-id (construct)
923	(:documentation "Returns the internal id that uniquely identifies a
924	construct (currently simply its OID)."))
925
926
927	(defmethod internal-id ((construct TopicMapConstructC))
928	(slot-value construct (find-symbol "OID" 'elephant)))
929
930
931	;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
932	(defgeneric mark-as-deleted (construct &key source-locator revision)
933	(:documentation "Mark a construct as deleted if it comes from the source
934	indicated by source-locator"))
935
936
937	(defgeneric marked-as-deleted-p (construct)
938	(:documentation "Returns t if the construct was marked-as-deleted."))
939
940
941	(defgeneric find-self-or-equal (construct parent-construct &key revision)
942	(:documentation "Returns the construct 'construct' if is owned by the
943	parent-construct or an equal construct or nil if there
944	is no equal one."))
945
946
947	(defgeneric merge-if-equivalent (new-characteristic parent-construct
948	&key revision)
949	(:documentation "Merges the new characteristic/role with one equivalent of the
950	parent's charateristics/roles instead of adding the entire new
951	characteristic/role to the parent."))
952
953
954	(defgeneric parent (construct &key revision)
955	(:documentation "Returns the parent construct of the passed object that
956	corresponds with the given revision. The returned construct
957	can be a TopicC or a NameC."))
958
959
960	(defgeneric delete-if-not-referenced (construct)
961	(:documentation "Calls delete-construct for the given object if it is
962	not referenced by any other construct."))
963
964
965	(defgeneric add-characteristic (construct characteristic &key revision)
966	(:documentation "Adds the passed characterisitc to the given topic by calling
967	add-name or add-occurrences.
968	Variants are added to names by calling add-name."))
969
970
971	(defgeneric private-delete-characteristic (construct characteristic &key revision)
972	(:documentation "Deletes the passed characteristic of the given topic by
973	calling delete-name or delete-occurrence.
974	Variants are deleted from names by calling delete-variant."))
975
976
977	(defgeneric delete-characteristic (construct characteristic &key revision)
978	(:documentation "See private-delete-characteristic but adds the parent
979	(if it is a variant also the parent's parent) to the
980	version history of this call's revision"))
981
982
983	(defgeneric find-oldest-construct (construct-1 construct-2)
984	(:documentation "Returns the construct which owns the oldes version info.
985	If a construct is not a versioned construct the oldest
986	association determines the construct's version info."))
987
988
989	(defgeneric merge-constructs (construct-1 construct-2 &key revision)
990	(:documentation "Merges two constructs of the same type if they are
991	mergable. The latest construct will be marked as deleted
992	The older one gets all characteristics of the marked as
993	deleted one. All referenced constructs are also updated
994	with the changeds that are caused by this operation."))
995
996
997	(defgeneric parent-delete-parent (construct parent-construct &key revision)
998	(:documentation "Sets the assoication-object between the passed
999	constructs as marded-as-deleted."))
1000
1001
1002	(defgeneric delete-parent (construct parent-construct &key revision)
1003	(:documentation "See private-delete-parent but adds the parent to
1004	the given version."))
1005
1006
1007	(defgeneric add-parent (construct parent-construct &key revision)
1008	(:documentation "Adds the parent-construct (TopicC or NameC) in form of
1009	a corresponding association to the given object."))
1010
1011
1012	(defgeneric find-item-by-revision (construct revision
1013	&optional parent-construct)
1014	(:documentation "Returns the given object if it exists in the passed
1015	version otherwise nil.
1016	Constructs that exist to be owned by parent-constructs
1017	must provide their parent-construct to get the corresponding
1018	revision of the relationship between the construct itself and
1019	its parent-construct."))
1020
1021
1022	(defgeneric check-for-duplicate-identifiers (construct &key revision)
1023	(:documentation "Check for possibly duplicate identifiers and signal an
1024	duplicate-identifier-error is such duplicates are found"))
1025
1026
1027	(defgeneric get-all-identifiers-of-construct (construct &key revision)
1028	(:documentation "Get all identifiers that a given construct has"))
1029
1030
1031	(defgeneric get-all-characteristics (parent-construct characteristic-symbol)
1032	(:documentation "Returns all characterisitcs of the passed type the parent
1033	construct was ever associated with."))
1034
1035
1036	(defgeneric equivalent-construct (construct &key start-revision
1037	&allow-other-keys)
1038	(:documentation "Returns t if the passed construct is equivalent to the passed
1039	key arguments (TMDM equality rules). Parent-equality is not
1040	checked in this methods, so the user has to pass children of
1041	the same parent."))
1042
1043
1044	(defgeneric equivalent-constructs (construct-1 construct-2 &key revision)
1045	(:documentation "Returns t if the passed constructs are equivalent to each
1046	other (TMDM equality rules). Parent-equality is not
1047	checked in this methods, so the user has to pass children of
1048	the same parent."))
1049
1050
1051	(defgeneric get-most-recent-version-info (construct)
1052	(:documentation "Returns the latest VersionInfoC object of the passed
1053	versioned construct.
1054	The latest construct is either the one with
1055	end-revision=0 or with the highest end-revision value."))
1056
1057	(defgeneric owned-p (construct)
1058	(:documentation "Returns t if the passed construct is referenced by a parent
1059	TM construct."))
1060
1061
1062	(defgeneric in-topicmaps (construct &key revision)
1063	(:documentation "Returns all TopicMaps-obejcts where the construct is
1064	contained in."))
1065
1066
1067	(defgeneric add-to-tm (construct construct-to-add)
1068	(:documentation "Adds a TM construct (TopicC or AssociationC) to the TM."))
1069
1070
1071	(defgeneric delete-from-tm (construct construct-to-delete)
1072	(:documentation "Deletes a TM construct (TopicC or AssociationC) from
1073	the TM."))
1074
1075
1076	(defgeneric any-id (construct &key revision)
1077	(:documentation "Returns any uri of the constructs identifier, except
1078	TopicIdentificationC. The order is: PSIs, SL, II."))
1079
1080
1081
1082	;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1083	;;; VersionInfocC
1084	(defmethod delete-construct :before ((version-info VersionInfoC))
1085	(delete-1-n-association version-info 'versioned-construct))
1086
1087
1088	;;; VersionedConstructC
1089	(defgeneric exist-in-version-history-p (versioned-construct)
1090	(:documentation "Returns t if the passed construct does not exist in any
1091	revision, i.e. the construct has no version-infos or exactly
1092	one whose start-revision is equal to its end-revision.")
1093	(:method ((versioned-construct VersionedConstructC))
1094	(or (not (versions versioned-construct))
1095	(and (= (length (versions versioned-construct)) 1)
1096	(= (start-revision (first (versions versioned-construct)))
1097	(end-revision (first (versions versioned-construct))))))))
1098
1099
1100	(defmethod find-oldest-construct ((construct-1 VersionedConstructC)
1101	(construct-2 VersionedConstructC))
1102	(let ((vi-1 (find-version-info (list construct-1)))
1103	(vi-2 (find-version-info (list construct-2))))
1104	(cond ((not (or vi-1 vi-2))
1105	construct-1)
1106	((not vi-1)
1107	construct-2)
1108	((not vi-2)
1109	construct-1)
1110	((<= (start-revision vi-1) (start-revision vi-2))
1111	construct-1)
1112	(t
1113	construct-2))))
1114
1115
1116	(defgeneric VersionedConstructC-p (class-symbol)
1117	(:documentation "Returns t if the passed class is equal to VersionedConstructC
1118	or one of its subtypes.")
1119	(:method ((class-symbol symbol))
1120	(or (eql class-symbol 'VersionedconstructC)
1121	(TopicC-p class-symbol)
1122	(TopicMapC-p class-symbol)
1123	(AssociationC-p class-symbol))))
1124
1125
1126	(defmethod delete-construct :before ((construct VersionedConstructC))
1127	(dolist (version-info (versions construct))
1128	(delete-construct version-info)))
1129
1130
1131	(defmethod find-item-by-revision ((construct VersionedConstructC)
1132	(revision integer) &optional parent-construct)
1133	(declare (ignorable parent-construct))
1134	(cond ((= revision 0)
1135	(find-most-recent-revision construct))
1136	(t
1137	(when (find-if
1138	#'(lambda(vi)
1139	(and (>= revision (start-revision vi))
1140	(or (< revision (end-revision vi))
1141	(= 0 (end-revision vi)))))
1142	(versions construct))
1143	construct))))
1144
1145
1146	(defmethod get-most-recent-version-info ((construct VersionedConstructC))
1147	(let ((result (find 0 (versions construct) :key #'end-revision)))
1148	(if result
1149	result ;current version-info -> end-revision = 0
1150	(let ((sorted-list (sort (versions construct)
1151	#'(lambda(x y)
1152	(> (end-revision x) (end-revision y))))))
1153	(when sorted-list
1154	(first sorted-list)))))) ;latest version-info of marked-as-deleted constructs -> highest integer
1155
1156
1157	(defgeneric find-most-recent-revision (construct)
1158	(:documentation "Returns the latest version-info-object of the passed
1159	construct.")
1160	(:method ((construct VersionedConstructC))
1161	(when (find 0 (versions construct) :key #'end-revision)
1162	construct)))
1163
1164
1165	(defmethod find-most-recent-revision ((construct CharacteristicC))
1166	(loop for c-assoc in (slot-p construct 'parent)
1167	when (find-most-recent-revision c-assoc)
1168	return construct))
1169
1170
1171	(defmethod find-most-recent-revision ((construct PointerC))
1172	(loop for p-assoc in (slot-p construct 'identified-construct)
1173	when (find-most-recent-revision p-assoc)
1174	return construct))
1175
1176
1177	(defmethod find-most-recent-revision ((construct RoleC))
1178	(loop for r-assoc in (slot-p construct 'parent)
1179	when (find-most-recent-revision r-assoc)
1180	return construct))
1181
1182
1183	(defun add-version-info(construct start-revision)
1184	"Adds 'construct' to the given version.
1185	If the construct is a VersionedConstructC add-to-version-history
1186	is called directly. Otherwise there is called a corresponding
1187	add-<whatever> method that adds recursively 'construct' to its
1188	parent and so on."
1189	(declare (type (or TopicMapConstructC VersionedConstructC) construct)
1190	(integer start-revision))
1191	(cond ((typep construct 'VersionedConstructC)
1192	(add-to-version-history construct :start-revision start-revision))
1193	((typep construct 'VariantC)
1194	(let ((name (parent construct :revision start-revision)))
1195	(when name
1196	(add-variant name construct :revision start-revision)
1197	(let ((top (parent name :revision start-revision)))
1198	(when top
1199	(add-name top name :revision start-revision))))))
1200	((typep construct 'CharacteristicC)
1201	(let ((top (parent construct :revision start-revision)))
1202	(when top
1203	(add-characteristic top construct :revision start-revision))))
1204	((typep construct 'RoleC)
1205	(let ((assoc (parent construct :revision start-revision)))
1206	(when assoc
1207	(add-role assoc construct :revision start-revision))))))
1208
1209
1210	(defgeneric add-to-version-history (construct &key start-revision end-revision)
1211	(:documentation "Adds version history to a versioned construct")
1212	(:method ((construct VersionedConstructC)
1213	&key (start-revision (error (make-missing-argument-condition "From add-to-version-history(): start revision must be present" 'start-revision 'add-to-version-history)))
1214	(end-revision 0))
1215	(let ((eql-version-info
1216	(find-if #'(lambda(vi)
1217	(and (= (start-revision vi) start-revision)
1218	(= (end-revision vi) end-revision)))
1219	(versions construct))))
1220	(if eql-version-info
1221	eql-version-info
1222	(let ((current-version-info
1223	(get-most-recent-version-info construct)))
1224	(cond
1225	((and current-version-info
1226	(= (end-revision current-version-info) start-revision))
1227	(setf (end-revision current-version-info) end-revision)
1228	current-version-info)
1229	((and current-version-info
1230	(= (end-revision current-version-info) 0))
1231	(setf (end-revision current-version-info) start-revision)
1232	(let ((vi (make-instance 'VersionInfoC
1233	:start-revision start-revision
1234	:end-revision end-revision)))
1235	(elephant:add-association vi 'versioned-construct construct)))
1236	(t
1237	(let ((vi (make-instance 'VersionInfoC
1238	:start-revision start-revision
1239	:end-revision end-revision)))
1240	(elephant:add-association vi 'versioned-construct construct)))))))))
1241
1242
1243
1244	(defmethod marked-as-deleted-p ((construct VersionedConstructC))
1245	(unless (find-if #'(lambda(vi)
1246	(= (end-revision vi) 0))
1247	(versions construct))
1248	t))
1249
1250
1251	(defmethod mark-as-deleted ((construct VersionedConstructC)
1252	&key source-locator revision)
1253	(declare (ignorable source-locator))
1254	(let
1255	((last-version ;the last active version
1256	(find 0 (versions construct) :key #'end-revision)))
1257	(if (and last-version
1258	(= (start-revision last-version) revision))
1259	(progn
1260	(delete-construct last-version)
1261	(let ((sorted-versions
1262	(sort (versions construct) #'> :key #'end-revision)))
1263	(when sorted-versions
1264	(setf (end-revision (first sorted-versions)) revision))))
1265	(when last-version
1266	(setf (end-revision last-version) revision)))))
1267
1268
1269	;;; TopicMapConstructC
1270	(defgeneric strictly-equivalent-constructs (construct-1 construct-2
1271	&key revision)
1272	(:documentation "Checks if two topic map constructs are not identical but
1273	equal according to the TMDM equality rules.")
1274	(:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapConstructC)
1275	&key (revision TM-REVISION))
1276	(declare (integer revision))
1277	(and (equivalent-constructs construct-1 construct-2 :revision revision)
1278	(not (eql construct-1 construct-2)))))
1279
1280
1281	(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)
1282	&key revision)
1283	(declare (ignorable revision construct))
1284	;do nothing
1285	)
1286
1287
1288	(defmethod get-all-characteristics ((parent-construct TopicC)
1289	(characteristic-symbol symbol))
1290	(cond ((OccurrenceC-p characteristic-symbol)
1291	(map 'list #'characteristic (slot-p parent-construct 'occurrences)))
1292	((NameC-p characteristic-symbol)
1293	(map 'list #'characteristic (slot-p parent-construct 'names)))))
1294
1295
1296	(defgeneric TopicMapConstructC-p (class-symbol)
1297	(:documentation "Returns t if the passed class is equal to TopicMapConstructC
1298	or one of its subtypes.")
1299	(:method ((class-symbol symbol))
1300	(or (eql class-symbol 'TopicMapConstructC)
1301	(ReifiableConstructC-p class-symbol)
1302	(PointerC-p class-symbol))))
1303
1304
1305	;;; PointerC
1306	(defmethod versions ((construct PointerC))
1307	"Returns all versions that are indirectly through all PointerAssocitiations
1308	bound to the passed pointer object."
1309	(loop for p-assoc in (slot-p construct 'identified-construct)
1310	append (versions p-assoc)))
1311
1312
1313	(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision)
1314	"Marks the last active relation between a pointer and its parent construct
1315	as deleted."
1316	(declare (ignorable source-locator))
1317	(let ((owner (identified-construct construct :revision 0)))
1318	(when owner
1319	(cond ((typep construct 'PersistentIdC)
1320	(private-delete-psi owner construct :revision revision))
1321	((typep construct 'SubjectLocatorC)
1322	(private-delete-locator owner construct :revision revision))
1323	((typep construct 'ItemIdentifierC)
1324	(private-delete-item-identifier owner construct :revision revision))
1325	((typep construct 'TopicIdentificationC)
1326	(private-delete-topic-identifier owner construct :revision revision))))))
1327
1328
1329	(defmethod marked-as-deleted-p ((construct PointerC))
1330	(unless (identified-construct construct :revision 0)
1331	t))
1332
1333
1334	(defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC))
1335	(let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct)))
1336	(vi-2 (find-version-info (slot-p construct-2 'identified-construct))))
1337	(cond ((not (or vi-1 vi-2))
1338	construct-1)
1339	((not vi-1)
1340	construct-2)
1341	((not vi-2)
1342	construct-1)
1343	((<= (start-revision vi-1) (start-revision vi-2))
1344	construct-1)
1345	(t
1346	construct-2))))
1347
1348
1349	(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC)
1350	&key (revision nil))
1351	(declare (ignorable revision))
1352	(string= (uri construct-1) (uri construct-2)))
1353
1354
1355	(defgeneric PointerC-p (class-symbol)
1356	(:documentation "Returns t if the passed symbol corresponds to the class
1357	PointerC or one of its subclasses.")
1358	(:method ((class-symbol symbol))
1359	(or (eql class-symbol 'PointerC)
1360	(IdentifierC-p class-symbol)
1361	(TopicIdentificationC-p class-symbol)
1362	(PersistentIdC-p class-symbol)
1363	(ItemIdentifierC-p class-symbol)
1364	(SubjectLocatorC-p class-symbol))))
1365
1366
1367	(defmethod equivalent-construct ((construct PointerC)
1368	&key start-revision (uri ""))
1369	"All Pointers are equal if they have the same URI value."
1370	(declare (string uri) (ignorable start-revision))
1371	(string= (uri construct) uri))
1372
1373
1374	(defmethod find-item-by-revision ((construct PointerC)
1375	(revision integer) &optional parent-construct)
1376	(if parent-construct
1377	(let ((parent-assoc
1378	(let ((assocs
1379	(remove-if
1380	#'null
1381	(map 'list #'(lambda(assoc)
1382	(when (eql (parent-construct assoc)
1383	parent-construct)
1384	assoc))
1385	(slot-p construct 'identified-construct)))))
1386	(when assocs
1387	(first assocs)))))
1388	(when parent-assoc
1389	(cond ((= revision 0)
1390	(find-most-recent-revision parent-assoc))
1391	(t
1392	(when (find-if
1393	#'(lambda(vi)
1394	(and (>= revision (start-revision vi))
1395	(or (< revision (end-revision vi))
1396	(= 0 (end-revision vi)))))
1397	(versions parent-assoc))
1398	construct)))))
1399	nil))
1400
1401
1402	(defmethod delete-construct :before ((construct PointerC))
1403	(dolist (p-assoc (slot-p construct 'identified-construct))
1404	(delete-construct p-assoc)))
1405
1406
1407	(defmethod owned-p ((construct PointerC))
1408	(when (slot-p construct 'identified-construct)
1409	t))
1410
1411
1412	(defgeneric identified-construct (construct &key revision)
1413	(:documentation "Returns the identified-construct -> ReifiableConstructC or
1414	TopicC that corresponds with the passed revision.")
1415	(:method ((construct PointerC) &key (revision TM-REVISION))
1416	(let ((assocs
1417	(map 'list #'parent-construct
1418	(filter-slot-value-by-revision construct 'identified-construct
1419	:start-revision revision))))
1420	(when assocs ;result must be nil or a list with one item
1421	(first assocs)))))
1422
1423
1424	;;; TopicIdentificationC
1425	(defmethod equivalent-constructs ((construct-1 TopicIdentificationC)
1426	(construct-2 TopicIdentificationC)
1427	&key (revision nil))
1428	(declare (ignorable revision))
1429	(and (call-next-method)
1430	(string= (xtm-id construct-1) (xtm-id construct-2))))
1431
1432
1433
1434	(defgeneric TopicIdentificationC-p (class-symbol)
1435	(:documentation "Returns t if the passed class symbol is equal
1436	to TopicIdentificationC.")
1437	(:method ((class-symbol symbol))
1438	(eql class-symbol 'TopicIdentificationC)))
1439
1440
1441	(defmethod equivalent-construct ((construct TopicIdentificationC)
1442	&key start-revision (uri "") (xtm-id ""))
1443	"TopicIdentifiers are equal if teh URI and XTM-ID values are equal."
1444	(declare (string uri xtm-id))
1445	(let ((equivalent-pointer (call-next-method
1446	construct :start-revision start-revision
1447	:uri uri)))
1448	(and equivalent-pointer
1449	(string= (xtm-id construct) xtm-id))))
1450
1451
1452	;;; IdentifierC
1453	(defgeneric IdentifierC-p (class-symbol)
1454	(:documentation "Returns t if the passed symbol is equal to IdentifierC
1455	or one of its sybtypes.")
1456	(:method ((class-symbol symbol))
1457	(or (eql class-symbol 'IdentifierC)
1458	(PersistentIdC-p class-symbol)
1459	(SubjectLocatorC-p class-symbol)
1460	(ItemIdentifierC-p class-symbol))))
1461
1462
1463	;;; PersistentIdC
1464	(defgeneric PersistentIdC-p (class-symbol)
1465	(:documentation "Returns t if the passed symbol is equal to PersistentIdC.")
1466	(:method ((class-symbol symbol))
1467	(eql class-symbol 'PersistentIdC)))
1468
1469
1470	;;; ItemIdentifierC
1471	(defgeneric ItemIdentifierC-p (class-symbol)
1472	(:documentation "Returns t if the passed symbol is equal to ItemIdentifierC.")
1473	(:method ((class-symbol symbol))
1474	(eql class-symbol 'ItemIdentifierC)))
1475
1476	;;; SubjectLocatorC
1477	(defgeneric SubjectLocatorC-p (class-symbol)
1478	(:documentation "Returns t if the passed symbol is equal to SubjectLocatorC.")
1479	(:method ((class-symbol symbol))
1480	(eql class-symbol 'SubjectLocatorC)))
1481
1482
1483	;;; PointerAssociationC
1484	(defmethod delete-construct :before ((construct PointerAssociationC))
1485	(delete-1-n-association construct 'identifier))
1486
1487
1488	;;; ItemIdAssociationC
1489	(defmethod delete-construct :before ((construct ItemIdAssociationC))
1490	(delete-1-n-association construct 'parent-construct))
1491
1492
1493	;;; TopicIdAssociationC
1494	(defmethod delete-construct :before ((construct TopicIdAssociationC))
1495	(delete-1-n-association construct 'parent-construct))
1496
1497
1498	;;; PersistentIdAssociationC
1499	(defmethod delete-construct :before ((construct PersistentIdAssociationC))
1500	(delete-1-n-association construct 'parent-construct))
1501
1502
1503	;;; SubjectLocatorAssociationC
1504	(defmethod delete-construct :before ((construct SubjectLocatorAssociationC))
1505	(delete-1-n-association construct 'parent-construct))
1506
1507
1508	;;; ReifierAssociationC
1509	(defmethod delete-construct :before ((construct ReifierAssociationC))
1510	(delete-1-n-association construct 'reifiable-construct)
1511	(delete-1-n-association construct 'reifier-topic))
1512
1513
1514	;;; TypeAssociationC
1515	(defmethod delete-construct :before ((construct TypeAssociationC))
1516	(delete-1-n-association construct 'type-topic)
1517	(delete-1-n-association construct 'typable-construct))
1518
1519
1520	;;; ScopeAssociationC
1521	(defmethod delete-construct :before ((construct ScopeAssociationC))
1522	(delete-1-n-association construct 'theme-topic)
1523	(delete-1-n-association construct 'scopable-construct))
1524
1525
1526	;;; CharacteristicAssociationC
1527	(defmethod delete-construct :before ((construct CharacteristicAssociationC))
1528	(delete-1-n-association construct 'characteristic))
1529
1530
1531	;;; OccurrenceAssociationC
1532	(defmethod delete-construct :before ((construct OccurrenceAssociationC))
1533	(delete-1-n-association construct 'parent-construct))
1534
1535
1536	;;; NameAssociationC
1537	(defmethod delete-construct :before ((construct NameAssociationC))
1538	(delete-1-n-association construct 'parent-construct))
1539
1540
1541	;;; VariantAssociationC
1542	(defmethod delete-construct :before ((construct VariantAssociationC))
1543	(delete-1-n-association construct 'parent-construct))
1544
1545
1546	;;; RoleAssociationC
1547	(defmethod delete-construct :before ((construct RoleAssociationC))
1548	(delete-1-n-association construct 'role)
1549	(delete-1-n-association construct 'parent-construct))
1550
1551
1552	;;; PlayerAssociationC
1553	(defmethod delete-construct :before ((construct PlayerAssociationC))
1554	(delete-1-n-association construct 'player-topic)
1555	(delete-1-n-association construct 'parent-construct))
1556
1557
1558	;;; TopicC
1559	(defmethod mark-as-deleted :around ((top TopicC)
1560	&key (source-locator nil sl-provided-p)
1561	revision)
1562	"Mark a topic as deleted if it comes from the source indicated by
1563	source-locator"
1564	;;Part 1b, 1.4.3.3.1:
1565	;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F
1566	;; * Let SI be the value of TopicSI element in ATOM entry E
1567	;; * feed F contains E)
1568	;; * entry E references topic fragment TF
1569	;; * Let LTM be the local topic map
1570	;; * Let T be the topic in LTM that has a subjectidentifier that matches SI
1571	;; * For all names, occurrences and associations in which T plays a role, TMC
1572	;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC
1573	;; * Merge in the fragment TF using SP as the base all generated source locators.
1574	(when (or (and (not source-locator) sl-provided-p)
1575	(and sl-provided-p
1576	(some (lambda (psi) (string-starts-with (uri psi) source-locator))
1577	(psis top :revision 0))))
1578	(mapc (lambda(psi)(mark-as-deleted psi :revision revision
1579	:source-locator source-locator))
1580	(psis top :revision 0))
1581	(mapc (lambda(sl)(mark-as-deleted sl :revision revision
1582	:source-locator source-locator))
1583	(locators top :revision 0))
1584	(mapc (lambda (name) (mark-as-deleted name :revision revision
1585	:source-locator source-locator))
1586	(names top :revision 0))
1587	(mapc (lambda (occ) (mark-as-deleted occ :revision revision
1588	:source-locator source-locator))
1589	(occurrences top :revision 0))
1590	(mapc (lambda (ass) (mark-as-deleted ass :revision revision
1591	:source-locator source-locator))
1592	(find-all-associations top :revision 0))
1593	(call-next-method)))
1594
1595
1596	(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC)
1597	&key (revision TM-REVISION))
1598	(declare (integer revision))
1599	(let ((ids-1 (union (union (item-identifiers construct-1 :revision revision)
1600	(locators construct-1 :revision revision))
1601	(psis construct-1 :revision revision)))
1602	(ids-2 (union (union (item-identifiers construct-2 :revision revision)
1603	(locators construct-2 :revision revision))
1604	(psis construct-2 :revision revision))))
1605	(when (intersection ids-1 ids-2)
1606	t)))
1607
1608
1609	(defgeneric TopicC-p (class-symbol)
1610	(:documentation "Returns t if the passed symbol is equal to TopicC.")
1611	(:method ((class-symbol symbol))
1612	(eql class-symbol 'TopicC)))
1613
1614
1615	(defmethod equivalent-construct ((construct TopicC)
1616	&key (start-revision TM-REVISION) (psis nil)
1617	(locators nil) (item-identifiers nil)
1618	(topic-identifiers nil))
1619	"Isidorus handles Topic-equality only by the topic's identifiers
1620	'psis', 'subject locators' and 'item identifiers'. Names and occurences
1621	are not checked becuase we don't know when a topic is finalized and owns
1622	all its charactersitics. T is returned if the topic owns one of the given
1623	identifier-URIs."
1624	(declare (integer start-revision) (list psis locators item-identifiers
1625	topic-identifiers))
1626	(when
1627	(intersection
1628	(union (union (psis construct :revision start-revision)
1629	(locators construct :revision start-revision))
1630	(union (item-identifiers construct :revision start-revision)
1631	(topic-identifiers construct :revision start-revision)))
1632	(union (union psis locators) (union item-identifiers topic-identifiers)))
1633	t))
1634
1635
1636	(defmethod delete-construct :before ((construct TopicC))
1637	(let ((psi-assocs-to-delete (slot-p construct 'psis))
1638	(sl-assocs-to-delete (slot-p construct 'locators))
1639	(name-assocs-to-delete (slot-p construct 'names))
1640	(occ-assocs-to-delete (slot-p construct 'occurrences))
1641	(role-assocs-to-delete (slot-p construct 'player-in-roles))
1642	(type-assocs-to-delete (slot-p construct 'used-as-type))
1643	(scope-assocs-to-delete (slot-p construct 'used-as-theme))
1644	(reifier-assocs-to-delete (slot-p construct 'reified-construct)))
1645	(let ((all-psis (map 'list #'identifier psi-assocs-to-delete))
1646	(all-sls (map 'list #'identifier sl-assocs-to-delete))
1647	(all-names (map 'list #'characteristic name-assocs-to-delete))
1648	(all-occs (map 'list #'characteristic occ-assocs-to-delete))
1649	(all-roles (map 'list #'parent-construct role-assocs-to-delete))
1650	(all-types (map 'list #'typable-construct type-assocs-to-delete)))
1651	(dolist (construct-to-delete (append psi-assocs-to-delete
1652	sl-assocs-to-delete
1653	name-assocs-to-delete
1654	occ-assocs-to-delete
1655	role-assocs-to-delete
1656	type-assocs-to-delete
1657	scope-assocs-to-delete
1658	reifier-assocs-to-delete))
1659	(delete-construct construct-to-delete))
1660	(dolist (candidate-to-delete (append all-psis all-sls all-names all-occs))
1661	(unless (owned-p candidate-to-delete)
1662	(delete-construct candidate-to-delete)))
1663	(dolist (candidate-to-delete all-roles)
1664	(unless (player-p candidate-to-delete)
1665	(delete-construct candidate-to-delete)))
1666	(dolist (candidate-to-delete all-types)
1667	(unless (instance-of-p candidate-to-delete)
1668	(delete-construct candidate-to-delete)))
1669	(dolist (tm (slot-p construct 'in-topicmaps))
1670	(remove-association construct 'in-topicmaps tm)))))
1671
1672
1673	(defmethod owned-p ((construct TopicC))
1674	(when (slot-p construct 'in-topicmaps)
1675	t))
1676
1677
1678	(defgeneric topic-id (construct &optional revision xtm-id)
1679	(:documentation "Returns the primary id of this item
1680	(= essentially the OID). If xtm-id is explicitly given,
1681	returns one of the topic-ids in that TM
1682	(which must then exist).")
1683	(:method ((construct TopicC) &optional (revision TM-REVISION) (xtm-id nil))
1684	(declare (type (or string null) xtm-id)
1685	(type (or integer null) revision))
1686	(if xtm-id
1687	(let ((possible-identifiers
1688	(remove-if-not
1689	#'(lambda(top-id)
1690	(string= (xtm-id top-id) xtm-id))
1691	(topic-identifiers construct :revision revision))))
1692	(unless possible-identifiers
1693	(error (make-object-not-found-condition (format nil "Could not find an object ~a in xtm-id ~a" construct xtm-id))))
1694	(uri (first possible-identifiers)))
1695	(concat "t" (write-to-string (internal-id construct))))))
1696
1697
1698	(defgeneric topic-identifiers (construct &key revision)
1699	(:documentation "Returns the TopicIdentificationC-objects that correspond
1700	with the passed construct and the passed version.")
1701	(:method ((construct TopicC) &key (revision TM-REVISION))
1702	(let ((assocs (filter-slot-value-by-revision
1703	construct 'topic-identifiers :start-revision revision)))
1704	(map 'list #'identifier assocs))))
1705
1706
1707	(defgeneric add-topic-identifier (construct topic-identifier &key revision)
1708	(:documentation "Adds the passed topic-identifier to the passed topic.
1709	If the topic-identifier is already related with the passed
1710	topic a new revision is added.
1711	If the passed identifer already identifies another object
1712	the identified-constructs are merged.")
1713	(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
1714	&key (revision TM-REVISION))
1715	(let ((all-ids
1716	(map 'list #'identifier (slot-p construct 'topic-identifiers)))
1717	(construct-to-be-merged
1718	(let ((id-owner (identified-construct topic-identifier
1719	:revision revision)))
1720	(when (not (eql id-owner construct))
1721	id-owner))))
1722	(let ((merged-construct construct))
1723	(cond (construct-to-be-merged
1724	(setf merged-construct
1725	(merge-constructs construct construct-to-be-merged
1726	:revision revision)))
1727	((find topic-identifier all-ids)
1728	(let ((ti-assoc (loop for ti-assoc in (slot-p construct
1729	'topic-identifiers)
1730	when (eql (identifier ti-assoc)
1731	topic-identifier)
1732	return ti-assoc)))
1733	(add-to-version-history ti-assoc :start-revision revision)))
1734	(t
1735	(make-construct 'TopicIdAssociationC
1736	:parent-construct construct
1737	:identifier topic-identifier
1738	:start-revision revision)))
1739	(add-to-version-history merged-construct :start-revision revision)
1740	merged-construct))))
1741
1742
1743	(defgeneric private-delete-topic-identifier
1744	(construct topic-identifier &key revision)
1745	(:documentation "Sets the association object between the passed constructs
1746	as mark-as-deleted.")
1747	(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
1748	&key (revision (error (make-missing-argument-condition "From private-delete-topic-identifier(): revision must be set" 'revision 'private-delete-topic-identifier))))
1749	(let ((assoc-to-delete (loop for ti-assoc in (slot-p construct 'topic-identifiers)
1750	when (eql (identifier ti-assoc) topic-identifier)
1751	return ti-assoc)))
1752	(when assoc-to-delete
1753	(mark-as-deleted assoc-to-delete :revision revision)
1754	construct))))
1755
1756
1757	(defgeneric delete-topic-identifier
1758	(construct topic-identifier &key revision)
1759	(:documentation "See private-delete-topic-identifier but adds the parent
1760	construct to the given version")
1761	(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
1762	&key (revision (error (make-missing-argument-condition "From delete-topic-identifier(): revision must be set" 'revision 'delete-topic-identifier))))
1763	(when (private-delete-topic-identifier construct topic-identifier
1764	:revision revision)
1765	(add-to-version-history construct :start-revision revision)
1766	construct)))
1767
1768
1769	(defgeneric psis (construct &key revision)
1770	(:documentation "Returns the PersistentIdC-objects that correspond
1771	with the passed construct and the passed version.")
1772	(:method ((construct TopicC) &key (revision TM-REVISION))
1773	(let ((assocs (filter-slot-value-by-revision
1774	construct 'psis :start-revision revision)))
1775	(map 'list #'identifier assocs))))
1776
1777
1778	(defgeneric add-psi (construct psi &key revision)
1779	(:documentation "Adds the passed psi to the passed topic.
1780	If the psi is already related with the passed
1781	topic a new revision is added.
1782	If the passed identifer already identifies another object
1783	the identified-constructs are merged.")
1784	(:method ((construct TopicC) (psi PersistentIdC)
1785	&key (revision TM-REVISION))
1786	(let ((all-ids
1787	(map 'list #'identifier (slot-p construct 'psis)))
1788	(construct-to-be-merged
1789	(let ((id-owner (identified-construct psi :revision revision)))
1790	(when (not (eql id-owner construct))
1791	id-owner))))
1792	(let ((merged-construct construct))
1793	(cond (construct-to-be-merged
1794	(setf merged-construct
1795	(merge-constructs construct construct-to-be-merged
1796	:revision revision)))
1797	((find psi all-ids)
1798	(let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis)
1799	when (eql (identifier psi-assoc) psi)
1800	return psi-assoc)))
1801	(add-to-version-history psi-assoc :start-revision revision)))
1802	(t
1803	(make-construct 'PersistentIdAssociationC
1804	:parent-construct construct
1805	:identifier psi
1806	:start-revision revision)))
1807	(add-to-version-history merged-construct :start-revision revision)
1808	merged-construct))))
1809
1810
1811	(defgeneric private-delete-psi (construct psi &key revision)
1812	(:documentation "Sets the association object between the passed constructs
1813	as mark-as-deleted.")
1814	(:method ((construct TopicC) (psi PersistentIdC)
1815	&key (revision (error (make-missing-argument-condition "From private-delete-psi(): revision must be set" 'revision 'private-delete-psi))))
1816	(let ((assoc-to-delete (loop for psi-assoc in (slot-p construct 'psis)
1817	when (eql (identifier psi-assoc) psi)
1818	return psi-assoc)))
1819	(when assoc-to-delete
1820	(mark-as-deleted assoc-to-delete :revision revision)
1821	construct))))
1822
1823
1824	(defgeneric delete-psi (construct psi &key revision)
1825	(:documentation "See private-delete-psis but adds the parent to the given
1826	version.")
1827	(:method ((construct TopicC) (psi PersistentIdC)
1828	&key (revision (error (make-missing-argument-condition "From delete-psi(): revision must be set" 'revision 'delete-psi))))
1829	(when (private-delete-psi construct psi :revision revision)
1830	(add-to-version-history construct :start-revision revision)
1831	construct)))
1832
1833
1834	(defgeneric locators (construct &key revision)
1835	(:documentation "Returns the SubjectLocatorC-objects that correspond
1836	with the passed construct and the passed version.")
1837	(:method ((construct TopicC) &key (revision TM-REVISION))
1838	(let ((assocs (filter-slot-value-by-revision
1839	construct 'locators :start-revision revision)))
1840	(map 'list #'identifier assocs))))
1841
1842
1843	(defgeneric add-locator (construct locator &key revision)
1844	(:documentation "Adds the passed locator to the passed topic.
1845	If the locator is already related with the passed
1846	topic a new revision is added.
1847	If the passed identifer already identifies another object
1848	the identified-constructs are merged.")
1849	(:method ((construct TopicC) (locator SubjectLocatorC)
1850	&key (revision TM-REVISION))
1851	(let ((all-ids
1852	(map 'list #'identifier (slot-p construct 'locators)))
1853	(construct-to-be-merged
1854	(let ((id-owner (identified-construct locator :revision revision)))
1855	(when (not (eql id-owner construct))
1856	id-owner))))
1857	(let ((merged-construct construct))
1858	(cond (construct-to-be-merged
1859	(setf merged-construct
1860	(merge-constructs construct construct-to-be-merged
1861	:revision revision)))
1862	((find locator all-ids)
1863	(let ((loc-assoc
1864	(loop for loc-assoc in (slot-p construct 'locators)
1865	when (eql (identifier loc-assoc) locator)
1866	return loc-assoc)))
1867	(add-to-version-history loc-assoc :start-revision revision)))
1868	(t
1869	(make-construct 'SubjectLocatorAssociationC
1870	:parent-construct construct
1871	:identifier locator
1872	:start-revision revision)))
1873	(add-to-version-history merged-construct :start-revision revision)
1874	merged-construct))))
1875
1876
1877	(defgeneric private-delete-locator (construct locator &key revision)
1878	(:documentation "Sets the association object between the passed constructs
1879	as mark-as-deleted.")
1880	(:method ((construct TopicC) (locator SubjectLocatorC)
1881	&key (revision (error (make-missing-argument-condition "From private-delete-locator(): revision must be set" 'revision 'private-delete-locator))))
1882	(let ((assoc-to-delete (loop for loc-assoc in (slot-p construct 'locators)
1883	when (eql (identifier loc-assoc) locator)
1884	return loc-assoc)))
1885	(when assoc-to-delete
1886	(mark-as-deleted assoc-to-delete :revision revision)
1887	construct))))
1888
1889
1890	(defgeneric delete-locator (construct locator &key revision)
1891	(:documentation "See private-delete-locator but add the parent construct
1892	to the given version.")
1893	(:method ((construct TopicC) (locator SubjectLocatorC)
1894	&key (revision (error (make-missing-argument-condition "From delete-locator(): revision must be set" 'revision 'delete-locator))))
1895	(when (private-delete-locator construct locator :revision revision)
1896	(add-to-version-history construct :start-revision revision)
1897	construct)))
1898
1899
1900	(defmethod get-all-identifiers-of-construct ((construct TopicC)
1901	&key (revision TM-REVISION))
1902	(declare (integer revision))
1903	(append (psis construct :revision revision)
1904	(locators construct :revision revision)
1905	(item-identifiers construct :revision revision)))
1906
1907
1908	(defun get-item-by-any-id (id-uri &key (revision d:TM-REVISION))
1909	"Returns a topic or REfifiableConstruct corresponding to the given uri."
1910	(declare (String id-uri)
1911	(Integer revision))
1912	(or (d:get-item-by-psi id-uri :revision revision)
1913	(get-item-by-item-identifier id-uri :revision revision)
1914	(get-item-by-locator id-uri :revision revision)))
1915
1916
1917	(defmethod any-id ((construct TopicC) &key (revision TM-REVISION))
1918	(declare (Integer revision))
1919	(let ((psi (when-do psis (psis construct :revision revision)
1920	(uri (first psis)))))
1921	(if psi
1922	psi
1923	(let ((sl (when-do sls (locators construct :revision revision)
1924	(uri (first sls)))))
1925	(if sl
1926	sl
1927	(call-next-method))))))
1928
1929
1930	(defgeneric names (construct &key revision)
1931	(:documentation "Returns the NameC-objects that correspond
1932	with the passed construct and the passed version.")
1933	(:method ((construct TopicC) &key (revision TM-REVISION))
1934	(let ((assocs (filter-slot-value-by-revision
1935	construct 'names :start-revision revision)))
1936	(map 'list #'characteristic assocs))))
1937
1938
1939	(defgeneric add-name (construct name &key revision)
1940	(:documentation "Adds the passed name to the passed topic.
1941	If the name is already related with the passed
1942	topic a new revision is added.
1943	If the passed name already owns another object
1944	an error is thrown.")
1945	(:method ((construct TopicC) (name NameC)
1946	&key (revision TM-REVISION))
1947	(when (and (parent name :revision revision)
1948	(not (eql (parent name :revision revision) construct)))
1949	(error (make-tm-reference-condition (format nil "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
1950	name construct (parent name :revision revision))
1951	name (parent name :revision revision) construct)))
1952	(if (merge-if-equivalent name construct :revision revision)
1953	construct
1954	(let ((all-names
1955	(map 'list #'characteristic (slot-p construct 'names))))
1956	(if (find name all-names)
1957	(let ((name-assoc
1958	(loop for name-assoc in (slot-p construct 'names)
1959	when (eql (parent-construct name-assoc)
1960	construct)
1961	return name-assoc)))
1962	(add-to-version-history name-assoc :start-revision revision))
1963	(make-construct 'NameAssociationC
1964	:parent-construct construct
1965	:characteristic name
1966	:start-revision revision))
1967	(add-to-version-history construct :start-revision revision)
1968	construct))))
1969
1970
1971	(defgeneric private-delete-name (construct name &key revision)
1972	(:documentation "Sets the association object between the passed constructs
1973	as mark-as-deleted.")
1974	(:method ((construct TopicC) (name NameC)
1975	&key (revision (error (make-missing-argument-condition "From private-delete-name(): revision must be set" 'revision 'private-delete-name))))
1976	(let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names)
1977	when (eql (characteristic name-assoc) name)
1978	return name-assoc)))
1979	(when assoc-to-delete
1980	(mark-as-deleted assoc-to-delete :revision revision)
1981	construct))))
1982
1983
1984	(defgeneric delete-name (construct name &key revision)
1985	(:documentation "See private-delete-name but adds the parent to
1986	the given version.")
1987	(:method ((construct TopicC) (name NameC)
1988	&key (revision (error (make-missing-argument-condition "From delete-name(): revision must be set" 'revision 'delete-name))))
1989	(when (private-delete-name construct name :revision revision)
1990	(add-to-version-history construct :start-revision revision)
1991	construct)))
1992
1993
1994	(defgeneric occurrences (construct &key revision)
1995	(:documentation "Returns the OccurrenceC-objects that correspond
1996	with the passed construct and the passed version.")
1997	(:method ((construct TopicC) &key (revision TM-REVISION))
1998	(let ((assocs (filter-slot-value-by-revision
1999	construct 'occurrences :start-revision revision)))
2000	(map 'list #'characteristic assocs))))
2001
2002
2003	(defgeneric add-occurrence (construct occurrence &key revision)
2004	(:documentation "Adds the passed occurrence to the passed topic.
2005	If the occurrence is already related with the passed
2006	topic a new revision is added.
2007	If the passed occurrence already owns another object
2008	an error is thrown.")
2009	(:method ((construct TopicC) (occurrence OccurrenceC)
2010	&key (revision TM-REVISION))
2011	(when (and (parent occurrence :revision revision)
2012	(not (eql (parent occurrence :revision revision) construct)))
2013	(error (make-tm-reference-condition (format nil "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
2014	occurrence construct (parent occurrence :revision revision))
2015	occurrence (parent occurrence :revision revision) construct)))
2016	(if (merge-if-equivalent occurrence construct :revision revision)
2017	construct
2018	(let ((all-occurrences
2019	(map 'list #'characteristic (slot-p construct 'occurrences))))
2020	(if (find occurrence all-occurrences)
2021	(let ((occ-assoc
2022	(loop for occ-assoc in (slot-p construct 'occurrences)
2023	when (eql (parent-construct occ-assoc) construct)
2024	return occ-assoc)))
2025	(add-to-version-history occ-assoc :start-revision revision))
2026	(make-construct 'OccurrenceAssociationC
2027	:parent-construct construct
2028	:characteristic occurrence
2029	:start-revision revision))
2030	(add-to-version-history construct :start-revision revision)
2031	construct))))
2032
2033
2034	(defgeneric private-delete-occurrence (construct occurrence &key revision)
2035	(:documentation "Sets the association object between the passed constructs
2036	as mark-as-deleted.")
2037	(:method ((construct TopicC) (occurrence OccurrenceC)
2038	&key (revision (error (make-missing-argument-condition "From private-delete-occurrence(): revision must be set" 'revision 'private-delete-occurrence))))
2039	(let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
2040	when (eql (characteristic occ-assoc) occurrence)
2041	return occ-assoc)))
2042	(when assoc-to-delete
2043	(mark-as-deleted assoc-to-delete :revision revision)
2044	construct))))
2045
2046
2047	(defgeneric delete-occurrence (construct occurrence &key revision)
2048	(:documentation "See private-delete-occurrence but adds the parent
2049	to the given version history.")
2050	(:method ((construct TopicC) (occurrence OccurrenceC)
2051	&key (revision (error (make-missing-argument-condition "From delete-occurrence(): revision must be set" 'revision 'delete-occurrence))))
2052	(when (private-delete-occurrence construct occurrence :revision revision)
2053	(add-to-version-history construct :start-revision revision)
2054	construct)))
2055
2056
2057	(defmethod add-characteristic ((construct TopicC)
2058	(characteristic CharacteristicC)
2059	&key (revision TM-REVISION))
2060	(declare (integer revision) (type (or NameC OccurrenceC) characteristic))
2061	(if (typep characteristic 'NameC)
2062	(add-name construct characteristic :revision revision)
2063	(add-occurrence construct characteristic :revision revision)))
2064
2065
2066	(defmethod private-delete-characteristic ((construct TopicC)
2067	(characteristic CharacteristicC)
2068	&key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic))))
2069	(declare (integer revision) (type (or NameC OccurrenceC) characteristic))
2070	(if (typep characteristic 'NameC)
2071	(private-delete-name construct characteristic :revision revision)
2072	(private-delete-occurrence construct characteristic
2073	:revision revision)))
2074
2075
2076	(defmethod delete-characteristic ((construct TopicC)
2077	(characteristic CharacteristicC)
2078	&key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic))))
2079	(declare (integer revision) (type (or NameC OccurrenceC) characteristic))
2080	(if (typep characteristic 'NameC)
2081	(delete-name construct characteristic :revision revision)
2082	(delete-occurrence construct characteristic :revision revision)))
2083
2084
2085	(defgeneric player-in-roles (construct &key revision)
2086	(:documentation "Returns the RoleC-objects that correspond
2087	with the passed construct and the passed version.")
2088	(:method ((construct TopicC) &key (revision TM-REVISION))
2089	(let ((assocs (filter-slot-value-by-revision
2090	construct 'player-in-roles :start-revision revision)))
2091	(map 'list #'parent-construct assocs))))
2092
2093
2094	(defgeneric used-as-type (construct &key revision)
2095	(:documentation "Returns the TypableC-objects that correspond
2096	with the passed construct and the passed version.")
2097	(:method ((construct TopicC) &key (revision TM-REVISION))
2098	(let ((assocs (filter-slot-value-by-revision
2099	construct 'used-as-type :start-revision revision)))
2100	(map 'list #'typable-construct assocs))))
2101
2102
2103	(defgeneric used-as-theme (construct &key revision)
2104	(:documentation "Returns the ScopableC-objects that correspond
2105	with the passed construct and the passed version.")
2106	(:method ((construct TopicC) &key (revision TM-REVISION))
2107	(let ((assocs (filter-slot-value-by-revision
2108	construct 'used-as-theme :start-revision revision)))
2109	(map 'list #'scopable-construct assocs))))
2110
2111
2112	(defgeneric reified-construct (construct &key revision)
2113	(:documentation "Returns the ReifiableConstructC-objects that correspond
2114	with the passed construct and the passed version.")
2115	(:method ((construct TopicC) &key (revision TM-REVISION))
2116	(let ((assocs (filter-slot-value-by-revision
2117	construct 'reified-construct :start-revision revision)))
2118	(when assocs
2119	(reifiable-construct (first assocs))))))
2120
2121
2122	(defgeneric add-reified-construct (construct reified-construct &key revision)
2123	(:documentation "Sets the passed construct as reified-consturct of the given
2124	topic.")
2125	(:method ((construct TopicC) (reified-construct ReifiableConstructC)
2126	&key (revision TM-REVISION))
2127	(declare (integer revision))
2128	(add-reifier reified-construct construct :revision revision)))
2129
2130
2131	(defgeneric private-delete-reified-construct
2132	(construct reified-construct &key revision)
2133	(:documentation "Unsets the passed construct as reified-construct of the
2134	given topic.")
2135	(:method ((construct TopicC) (reified-construct ReifiableConstructC)
2136	&key (revision (error (make-missing-argument-condition "From private-delete-reified-construct(): revision must be set" 'revision 'private-delete-reified-construct))))
2137	(declare (integer revision))
2138	(private-delete-reifier reified-construct construct
2139	:revision revision)))
2140
2141
2142	(defgeneric delete-reified-construct (construct reified-construct &key revision)
2143	(:documentation "See private-delete-reified-construct but adds the
2144	reifier to the given version.")
2145	(:method ((construct TopicC) (reified-construct ReifiableConstructC)
2146	&key (revision (error (make-missing-argument-condition "From -delete-reified-construct(): revision must be set" 'revision '-delete-reified-construct))))
2147	(declare (integer revision))
2148	(delete-reifier reified-construct construct :revision revision)))
2149
2150
2151	(defmethod in-topicmaps ((topic TopicC) &key (revision TM-REVISION))
2152	(filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))
2153
2154
2155	(defun get-item-by-id (topic-id &key (xtm-id CURRENT-XTM)
2156	(revision TM-REVISION) (error-if-nil nil))
2157	"Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM
2158	is chosen. If xtm-id is nil, choose the global TM with its internal ID, if
2159	applicable in the correct revision. If revison is provided, then the code checks
2160	if the topic already existed in this revision and returns nil otherwise.
2161	If no item meeting the constraints was found, then the return value is either
2162	NIL or an error is thrown, depending on error-if-nil."
2163	(declare (string topic-id) (integer revision))
2164	(let ((result
2165	(if xtm-id
2166	(let ((possible-top-ids
2167	(delete-if-not
2168	#'(lambda(top-id)
2169	(and (typep top-id 'd:TopicIdentificationC)
2170	;fixes a bug in elephant -> all PointerCs are returned
2171	(string= (xtm-id top-id) xtm-id)
2172	(string= (uri top-id) topic-id)))
2173	;fixes a bug in get-instances-by-value that does a
2174	;case-insensitive comparision
2175	(elephant:get-instances-by-value
2176	'TopicIdentificationC
2177	'uri topic-id))))
2178	(when (and possible-top-ids
2179	(identified-construct (first possible-top-ids)
2180	:revision revision))
2181	(unless (= (length possible-top-ids) 1)
2182	(error (make-duplicate-identifier-condition
2183	(format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1"
2184	possible-top-ids topic-id xtm-id)
2185	topic-id)))
2186	(identified-construct (first possible-top-ids)
2187	:revision revision)
2188	;no revision need not to be checked, since the revision
2189	;is implicitely checked by the function identified-construct
2190	))
2191	(when (and (> (length topic-id) 0)
2192	(eql (elt topic-id 0) #\t)
2193	(string-integer-p (subseq topic-id 1)))
2194	(let ((top-from-oid
2195	(elephant::controller-recreate-instance
2196	elephant::store-controller
2197	(parse-integer (subseq topic-id 1)))))
2198	(when (find-item-by-revision top-from-oid revision)
2199	top-from-oid))))))
2200	(if (and error-if-nil (not result))
2201	(error (make-object-not-found-condition (format nil "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision)))
2202	result)))
2203
2204
2205	(defun get-item-by-identifier (uri &key (revision TM-REVISION)
2206	(identifier-type-symbol 'PersistentIdC)
2207	(error-if-nil nil))
2208	"Returns the construct that is bound to the given identifier-uri."
2209	(declare (string uri) (integer revision) (symbol identifier-type-symbol))
2210	(let ((result
2211	(let ((possible-ids
2212	(delete-if-not
2213	#'(lambda(id)
2214	(and (typep id identifier-type-symbol)
2215	(string= (uri id) uri)))
2216	(get-instances-by-value identifier-type-symbol 'uri uri))))
2217	(when (and possible-ids
2218	(identified-construct (first possible-ids)
2219	:revision revision))
2220	(unless (= (length possible-ids) 1)
2221	(error (make-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri)))
2222	(identified-construct (first possible-ids)
2223	:revision revision)))))
2224	;no revision need to be checked, since the revision
2225	;is implicitely checked by the function identified-construct
2226	(if result
2227	result
2228	(when error-if-nil
2229	(error (make-object-not-found-condition "No such item is bound to the given identifier uri."))))))
2230	;(if (and result
2231	;(let ((parent-elem
2232	;(when (or (typep result 'CharacteristicC)
2233	;(typep result 'RoleC))
2234	;(parent result :revision revision))))
2235	;(find-item-by-revision result revision parent-elem)))
2236	;result
2237	;(when error-if-nil
2238	;(error (make-object-not-found-condition "No such item is bound to the given identifier uri."))))))
2239
2240
2241	(defun get-item-by-item-identifier (uri &key (revision TM-REVISION)
2242	(error-if-nil nil))
2243	"Returns a ReifiableConstructC that is bound to the identifier-uri."
2244	(get-item-by-identifier uri :revision revision
2245	:identifier-type-symbol 'ItemIdentifierC
2246	:error-if-nil error-if-nil))
2247
2248
2249	(defun get-item-by-psi (uri &key (revision TM-REVISION) (error-if-nil nil))
2250	"Returns a TopicC that is bound to the identifier-uri."
2251	(get-item-by-identifier uri :revision revision
2252	:identifier-type-symbol 'PersistentIdC
2253	:error-if-nil error-if-nil))
2254
2255
2256	(defun get-item-by-locator (uri &key (revision TM-REVISION) (error-if-nil nil))
2257	"Returns a TopicC that is bound to the identifier-uri."
2258	(get-item-by-identifier uri :revision revision
2259	:identifier-type-symbol 'SubjectLocatorC
2260	:error-if-nil error-if-nil))
2261
2262
2263	(defgeneric instanceOf-association-p (construct &key revision)
2264	(:documentation "Returns t if the passed construct is an
2265	instance-of association.")
2266	(:method ((construct AssociationC) &key (revision TM-REVISION))
2267	(declare (Integer revision))
2268	(let ((type-top
2269	(get-item-by-psi type-psi :revision revision))
2270	(instance-top
2271	(get-item-by-psi instance-psi :revision revision))
2272	(type-instance-top
2273	(get-item-by-psi type-instance-psi :revision revision)))
2274	(when (and
2275	(eql (instance-of construct :revision revision) type-instance-top)
2276	(find-if #'(lambda(role)
2277	(eql (instance-of role :revision revision) type-top))
2278	(roles construct :revision revision))
2279	(find-if #'(lambda(role)
2280	(eql (instance-of role :revision revision) instance-top))
2281	(roles construct :revision revision)))
2282	t))))
2283
2284
2285	(defgeneric list-instanceOf (topic &key tm revision)
2286	(:documentation "Generates a list of all topics that this topic is an
2287	instance of, optionally filtered by a topic map")
2288	(:method ((topic TopicC) &key (tm nil) (revision TM-REVISION))
2289	(declare (type (or null TopicMapC) tm)
2290	(integer revision))
2291	(remove-if
2292	#'null
2293	(map 'list
2294	#'(lambda(x)
2295	(when (and (parent x :revision revision)
2296	(instance-of x :revision revision)
2297	(loop for psi in (psis (instance-of x :revision revision)
2298	:revision revision)
2299	when (string= (uri psi) constants:instance-psi)
2300	return t))
2301	(loop for role in (roles (parent x :revision revision)
2302	:revision revision)
2303	when (not (eq role x))
2304	return (player role :revision revision))))
2305	(if tm
2306	(remove-if-not
2307	(lambda (role)
2308	(in-topicmap tm (parent role :revision revision)
2309	:revision revision))
2310	(player-in-roles topic :revision revision))
2311	(player-in-roles topic :revision revision))))))
2312
2313
2314	(defgeneric list-super-types (topic &key tm revision)
2315	(:documentation "Generate a list of all topics that this topic is an
2316	subclass of, optionally filtered by a topic map")
2317	(:method ((topic TopicC) &key (tm nil) (revision TM-REVISION))
2318	(declare (type (or null TopicMapC) tm)
2319	(integer revision))
2320	(remove-if
2321	#'null
2322	(map 'list
2323	#'(lambda(x)
2324	(when (loop for psi in (psis (instance-of x :revision revision)
2325	:revision revision)
2326	when (string= (uri psi) subtype-psi)
2327	return t)
2328	(loop for role in (roles (parent x :revision revision)
2329	:revision revision)
2330	when (not (eq role x))
2331	return (player role :revision revision))))
2332	(if tm
2333	(remove-if-not
2334	(lambda (role)
2335	(in-topicmap tm (parent role :revision revision)
2336	:revision revision))
2337	(player-in-roles topic :revision revision))
2338	(player-in-roles topic :revision revision))))))
2339
2340
2341	;;; CharacteristicC
2342	(defmethod versions ((construct CharacteristicC))
2343	"Returns all versions that are indirectly through all
2344	CharacteristicAssocitiations bound to the passed characteristic object."
2345	(loop for p-assoc in (slot-p construct 'parent)
2346	append (versions p-assoc)))
2347
2348
2349	(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision)
2350	"Marks the last active relation between a characteristic and its parent topic
2351	as deleted."
2352	(declare (ignorable source-locator))
2353	(let ((owner (parent construct :revision 0)))
2354	(when owner
2355	(private-delete-characteristic owner construct :revision revision))))
2356
2357
2358	(defmethod marked-as-deleted-p ((construct CharacteristicC))
2359	(unless (parent construct :revision 0)
2360	t))
2361
2362
2363	(defmethod find-self-or-equal ((construct CharacteristicC)
2364	(parent-construct TopicC)
2365	&key (revision TM-REVISION))
2366	(declare (integer revision) (type (or OccurrenceC NameC) construct))
2367	(let ((chars (if (typep construct 'OccurrenceC)
2368	(occurrences parent-construct :revision revision)
2369	(names parent-construct :revision revision))))
2370	(let ((self (find construct chars)))
2371	(if self
2372	self
2373	(let ((equal-char
2374	(remove-if #'null
2375	(map 'list
2376	#'(lambda(char)
2377	(strictly-equivalent-constructs
2378	char construct :revision revision))
2379	chars))))
2380	(when equal-char
2381	(first equal-char)))))))
2382
2383
2384	(defmethod delete-if-not-referenced ((construct CharacteristicC))
2385	(let ((references (slot-p construct 'parent)))
2386	(when (or (not references)
2387	(and (= (length references) 1)
2388	(marked-as-deleted-p (first references))))
2389	(delete-construct construct))))
2390
2391
2392	(defmethod find-oldest-construct ((construct-1 CharacteristicC)
2393	(construct-2 CharacteristicC))
2394	(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
2395	(vi-2 (find-version-info (slot-p construct-2 'parent))))
2396	(cond ((not (or vi-1 vi-2))
2397	construct-1)
2398	((not vi-1)
2399	construct-2)
2400	((not vi-2)
2401	construct-1)
2402	((<= (start-revision vi-1) (start-revision vi-2))
2403	construct-1)
2404	(t
2405	construct-2))))
2406
2407
2408	(defmethod equivalent-constructs ((construct-1 CharacteristicC)
2409	(construct-2 CharacteristicC)
2410	&key (revision TM-REVISION))
2411	(declare (integer revision))
2412	(and (string= (charvalue construct-1) (charvalue construct-2))
2413	(eql (instance-of construct-1 :revision revision)
2414	(instance-of construct-2 :revision revision))
2415	(not (set-exclusive-or (themes construct-1 :revision revision)
2416	(themes construct-2 :revision revision)))))
2417
2418
2419	(defgeneric CharacteristicC-p (class-symbol)
2420	(:documentation "Returns t if the passed symbol is equal to CharacteristicC
2421	or one of its subtypes.")
2422	(:method ((class-symbol symbol))
2423	(or (eql class-symbol 'CharacteristicC)
2424	(OccurrenceC-p class-symbol)
2425	(NameC-p class-symbol)
2426	(VariantC-p class-symbol))))
2427
2428
2429	(defmethod equivalent-construct ((construct CharacteristicC)
2430	&key (start-revision TM-REVISION)
2431	(charvalue "") (instance-of nil) (themes nil))
2432	"Equality rule: Characteristics are equal if charvalue, themes and
2433	instance-of are equal."
2434	(declare (string charvalue) (list themes)
2435	(integer start-revision)
2436	(type (or null TopicC) instance-of))
2437	;; item-identifiers and reifers are not checked because the equality have to
2438	;; be variafied without them
2439	(and (string= (charvalue construct) charvalue)
2440	(equivalent-scopable-construct construct themes
2441	:start-revision start-revision)
2442	(equivalent-typable-construct construct instance-of
2443	:start-revision start-revision)))
2444
2445
2446	(defmethod find-item-by-revision ((construct CharacteristicC)
2447	(revision integer) &optional parent-construct)
2448	(if parent-construct
2449	(let ((parent-assoc
2450	(let ((assocs
2451	(remove-if
2452	#'null
2453	(map 'list #'(lambda(assoc)
2454	(when (eql (parent-construct assoc)
2455	parent-construct)
2456	assoc))
2457	(slot-p construct 'parent)))))
2458	(when assocs
2459	(first assocs)))))
2460	(when parent-assoc
2461	(cond ((= revision 0)
2462	(when
2463	(find-most-recent-revision parent-assoc)
2464	construct))
2465	(t
2466	(when (find-if
2467	#'(lambda(vi)
2468	(and (>= revision (start-revision vi))
2469	(or (< revision (end-revision vi))
2470	(= 0 (end-revision vi)))))
2471	(versions parent-assoc))
2472	construct)))))
2473	nil))
2474
2475
2476	(defmethod delete-construct :before ((construct CharacteristicC))
2477	(dolist (characteristic-assoc-to-delete (slot-p construct 'parent))
2478	(delete-construct characteristic-assoc-to-delete)))
2479
2480
2481	(defmethod owned-p ((construct CharacteristicC))
2482	(when (slot-p construct 'parent)
2483	t))
2484
2485
2486	(defmethod parent ((construct CharacteristicC) &key (revision TM-REVISION))
2487	(let ((valid-associations
2488	(filter-slot-value-by-revision construct 'parent
2489	:start-revision revision)))
2490	(when valid-associations
2491	(parent-construct (first valid-associations)))))
2492
2493
2494	(defmethod add-parent ((construct CharacteristicC)
2495	(parent-construct ReifiableConstructC)
2496	&key (revision TM-REVISION))
2497	(declare (integer revision))
2498	(let ((already-set-parent (parent construct :revision revision))
2499	(same-parent-assoc ;should contain an object that was marked as deleted
2500	(loop for parent-assoc in (slot-p construct 'parent)
2501	when (eql parent-construct (parent-construct parent-assoc))
2502	return parent-assoc)))
2503	(when (and already-set-parent
2504	(not (eql already-set-parent parent-construct)))
2505	(error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
2506	construct parent-construct already-set-parent)
2507	construct (parent construct :revision revision) parent-construct)))
2508	(let ((merged-char
2509	(merge-if-equivalent construct parent-construct :revision revision)))
2510	(if merged-char
2511	merged-char
2512	(progn
2513	(cond (already-set-parent
2514	(let ((parent-assoc
2515	(loop for parent-assoc in (slot-p construct 'parent)
2516	when (eql parent-construct
2517	(parent-construct parent-assoc))
2518	return parent-assoc)))
2519	(add-to-version-history parent-assoc
2520	:start-revision revision)))
2521	(same-parent-assoc
2522	(add-to-version-history same-parent-assoc
2523	:start-revision revision))
2524	(t
2525	(let ((association-type (cond ((typep construct 'OccurrenceC)
2526	'OccurrenceAssociationC)
2527	((typep construct 'NameC)
2528	'NameAssociationC)
2529	(t
2530	'VariantAssociationC))))
2531	(make-construct association-type
2532	:characteristic construct
2533	:parent-construct parent-construct
2534	:start-revision revision))))
2535	(when (typep parent-construct 'VersionedConstructC)
2536	(add-to-version-history parent-construct :start-revision revision))
2537	construct)))))
2538
2539
2540	(defmethod private-delete-parent ((construct CharacteristicC)
2541	(parent-construct ReifiableConstructC)
2542	&key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent))))
2543	(let ((assoc-to-delete
2544	(loop for parent-assoc in (slot-p construct 'parent)
2545	when (eql (parent-construct parent-assoc) parent-construct)
2546	return parent-assoc)))
2547	(when assoc-to-delete
2548	(mark-as-deleted assoc-to-delete :revision revision)
2549	construct)))
2550
2551
2552	(defmethod delete-parent ((construct CharacteristicC)
2553	(parent-construct ReifiableConstructC)
2554	&key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent))))
2555	(let ((parent (parent construct :revision revision)))
2556	(when (private-delete-parent construct parent-construct :revision revision)
2557	(when parent
2558	(add-version-info parent revision))
2559	construct)))
2560
2561
2562	;;; OccurrenceC
2563	(defmethod equivalent-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC)
2564	&key (revision TM-REVISION))
2565	(declare (ignorable revision))
2566	(and (call-next-method)
2567	(string= (datatype construct-1) (datatype construct-2))))
2568
2569
2570	(defgeneric OccurrenceC-p (class-symbol)
2571	(:documentation "Returns t if the passed symbol is equal to OccurrenceC.")
2572	(:method ((class-symbol symbol))
2573	(eql class-symbol 'OccurrenceC)))
2574
2575
2576	(defmethod equivalent-construct ((construct OccurrenceC)
2577	&key (start-revision TM-REVISION)
2578	(charvalue "") (themes nil) (instance-of nil)
2579	(datatype ""))
2580	"Occurrences are equal if their charvalue, datatype, themes and
2581	instance-of properties are equal."
2582	(declare (type (or null TopicC) instance-of) (string datatype)
2583	(ignorable start-revision charvalue themes instance-of))
2584	(let ((equivalent-characteristic (call-next-method)))
2585	;; item-identifiers and reifers are not checked because the equaity have to
2586	;; be variafied without them
2587	(and equivalent-characteristic
2588	(string= (datatype construct) datatype))))
2589
2590
2591	;;; VariantC
2592	(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC)
2593	&key (revision TM-REVISION))
2594	(declare (integer revision))
2595	(let ((vars (variants parent-construct :revision revision)))
2596	(let ((self (find construct vars)))
2597	(if self
2598	self
2599	(let ((equal-var
2600	(remove-if #'null
2601	(map 'list
2602	#'(lambda(var)
2603	(strictly-equivalent-constructs
2604	var construct :revision revision))
2605	vars))))
2606	(when equal-var
2607	(first equal-var)))))))
2608
2609
2610	(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC)
2611	&key (revision TM-REVISION))
2612	(declare (ignorable revision))
2613	(and (call-next-method)
2614	(string= (datatype construct-1) (datatype construct-2))))
2615
2616
2617	(defgeneric VariantC-p (class-symbol)
2618	(:documentation "Returns t if the passed symbol is equal to VariantC.")
2619	(:method ((class-symbol symbol))
2620	(eql class-symbol 'VariantC)))
2621
2622
2623	(defmethod equivalent-construct ((construct VariantC)
2624	&key (start-revision TM-REVISION)
2625	(charvalue "") (themes nil) (datatype ""))
2626	"Variants are equal if their charvalue, datatype and themes
2627	properties are equal."
2628	(declare (string datatype) (ignorable start-revision charvalue themes))
2629	;; item-identifiers and reifers are not checked because the equality have to
2630	;; be variafied without them
2631	(let ((equivalent-characteristic (call-next-method)))
2632	(and equivalent-characteristic
2633	(string= (datatype construct) datatype))))
2634
2635
2636	;;; NameC
2637	(defmethod get-all-characteristics ((parent-construct NameC)
2638	(characteristic-symbol symbol))
2639	(when (VariantC-p characteristic-symbol)
2640	(map 'list #'characteristic (slot-p parent-construct 'variants))))
2641
2642
2643	(defgeneric NameC-p (class-symbol)
2644	(:documentation "Returns t if the passed symbol is equal to Name.")
2645	(:method ((class-symbol symbol))
2646	(eql class-symbol 'NameC)))
2647
2648
2649	(defgeneric complete-name (construct variants &key start-revision)
2650	(:documentation "Adds all given variants to the passed construct.")
2651	(:method ((construct NameC) (variants list)
2652	&key (start-revision TM-REVISION))
2653	(dolist (variant variants)
2654	(add-variant construct variant :revision start-revision))
2655	construct))
2656
2657
2658	(defmethod equivalent-construct ((construct NameC)
2659	&key (start-revision TM-REVISION)
2660	(charvalue "") (themes nil) (instance-of nil))
2661	"Names are equal if their charvalue, instance-of and themes properties
2662	are equal."
2663	(declare (type (or null TopicC) instance-of)
2664	(ignorable start-revision charvalue instance-of themes))
2665	(call-next-method))
2666
2667
2668	(defmethod delete-construct :before ((construct NameC))
2669	(let ((variant-assocs-to-delete (slot-p construct 'variants)))
2670	(let ((all-variants (map 'list #'characteristic variant-assocs-to-delete)))
2671	(dolist (variant-assoc-to-delete variant-assocs-to-delete)
2672	(delete-construct variant-assoc-to-delete))
2673	(dolist (candidate-to-delete all-variants)
2674	(unless (owned-p candidate-to-delete)
2675	(delete-construct candidate-to-delete))))))
2676
2677
2678	(defgeneric variants (construct &key revision)
2679	(:documentation "Returns all variants that correspond with the given revision
2680	and that are associated with the passed construct.")
2681	(:method ((construct NameC) &key (revision TM-REVISION))
2682	(let ((valid-associations
2683	(filter-slot-value-by-revision construct 'variants
2684	:start-revision revision)))
2685	(map 'list #'characteristic valid-associations))))
2686
2687
2688	(defgeneric add-variant (construct variant &key revision)
2689	(:documentation "Adds the given theme-topic to the passed
2690	scopable-construct.")
2691	(:method ((construct NameC) (variant VariantC)
2692	&key (revision TM-REVISION))
2693	(when (and (parent variant :revision revision)
2694	(not (eql (parent variant :revision revision) construct)))
2695	(error (make-tm-reference-condition (format nil "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
2696	variant construct (parent variant :revision revision))
2697	variant (parent variant :revision revision) construct)))
2698	(if (merge-if-equivalent variant construct :revision revision)
2699	construct
2700	(let ((all-variants
2701	(map 'list #'characteristic (slot-p construct 'variants))))
2702	(if (find variant all-variants)
2703	(let ((variant-assoc
2704	(loop for variant-assoc in (slot-p construct 'variants)
2705	when (eql (characteristic variant-assoc) variant)
2706	return variant-assoc)))
2707	(add-to-version-history variant-assoc :start-revision revision))
2708	(make-construct 'VariantAssociationC
2709	:characteristic variant
2710	:parent-construct construct
2711	:start-revision revision))
2712	(when (parent construct :revision revision)
2713	(add-name (parent construct :revision revision) construct
2714	:revision revision))
2715	construct))))
2716
2717
2718	(defgeneric private-delete-variant (construct variant &key revision)
2719	(:documentation "Deletes the passed variant by marking it's association as
2720	deleted in the passed revision.")
2721	(:method ((construct NameC) (variant VariantC)
2722	&key (revision (error (make-missing-argument-condition "From private-delete-variant(): revision must be set" 'revision 'private-delete-variant))))
2723	(let ((assoc-to-delete (loop for variant-assoc in (slot-p construct
2724	'variants)
2725	when (eql (characteristic variant-assoc) variant)
2726	return variant-assoc)))
2727	(when assoc-to-delete
2728	(mark-as-deleted assoc-to-delete :revision revision)
2729	construct))))
2730
2731
2732	(defgeneric delete-variant (construct variant &key revision)
2733	(:documentation "See private-delete-variant but adds a the parent
2734	and the parent's parent to the given version history.")
2735	(:method ((construct NameC) (variant VariantC)
2736	&key (revision (error (make-missing-argument-condition "From delete-variant(): revision must be set" 'revision 'delete-variant))))
2737	(when (private-delete-variant construct variant :revision revision)
2738	(when (parent construct :revision revision)
2739	(add-name (parent construct :revision revision) construct
2740	:revision revision)
2741	construct))))
2742
2743
2744	(defmethod add-characteristic ((construct NameC) (characteristic VariantC)
2745	&key (revision TM-REVISION))
2746	(declare (integer revision))
2747	(add-variant construct characteristic :revision revision))
2748
2749
2750	(defmethod private-delete-characteristic ((construct NameC) (characteristic VariantC)
2751	&key (revision (error (make-missing-argument-condition "From private-delete-characteristic(): revision must be set" 'revision 'private-delete-characteristic))))
2752	(declare (integer revision))
2753	(private-delete-variant construct characteristic :revision revision))
2754
2755
2756	(defmethod delete-characteristic ((construct NameC) (characteristic VariantC)
2757	&key (revision (error (make-missing-argument-condition "From delete-characteristic(): revision must be set" 'revision 'delete-characteristic))))
2758	(declare (integer revision))
2759	(delete-variant construct characteristic :revision revision))
2760
2761
2762	;;; AssociationC
2763	(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision)
2764	"Marks an association and its roles as deleted"
2765	(mapc (lambda (role)
2766	(mark-as-deleted role :revision revision :source-locator source-locator))
2767	(roles ass :revision 0))
2768	(call-next-method))
2769
2770
2771	(defmethod equivalent-constructs ((construct-1 AssociationC)
2772	(construct-2 AssociationC)
2773	&key (revision TM-REVISION))
2774	(declare (ignorable revision))
2775	(and (eql (instance-of construct-1 :revision revision)
2776	(instance-of construct-2 :revision revision))
2777	(not (set-exclusive-or (themes construct-1 :revision revision)
2778	(themes construct-2 :revision revision)))
2779
2780	(not (set-exclusive-or
2781	(roles construct-1 :revision revision)
2782	(roles construct-2 :revision revision)
2783	:test #'(lambda(role-1 role-2)
2784	;(strictly-equivalent-constructs role-1 role-2
2785	;:revision revision))))))
2786	(equivalent-constructs role-1 role-2
2787	:revision revision))))))
2788
2789
2790	(defgeneric AssociationC-p (class-symbol)
2791	(:documentation "Returns t if the passed symbol is equal to AssociationC.")
2792	(:method ((class-symbol symbol))
2793	(eql class-symbol 'AssociationC)))
2794
2795
2796	(defmethod equivalent-construct ((construct AssociationC)
2797	&key (start-revision TM-REVISION)
2798	(roles nil) (instance-of nil) (themes nil))
2799	"Associations are equal if their themes, instance-of and roles
2800	properties are equal.
2801	To avoid ceation of duplicate roles the parameter roles is a list of plists
2802	of the form: ((:player <TopicC> :instance-of <TopicC>
2803	:item-identifiers <(ItemIdentifierC)> :reifier <TopicC>))."
2804	(declare (integer start-revision) (list roles themes)
2805	(type (or null TopicC) instance-of))
2806	;; item-identifiers and reifers are not checked because the equality have to
2807	;; be variafied without them
2808	(let ((checked-roles nil))
2809	(loop for plist in roles
2810	do (let ((found-role
2811	(find-if #'(lambda(assoc-role)
2812	(equivalent-construct
2813	assoc-role :player (getf plist :player)
2814	:start-revision (or (getf plist :start-revision)
2815	start-revision)
2816	:instance-of (getf plist :instance-of)))
2817	(roles construct :revision start-revision))))
2818	(when found-role
2819	(push found-role checked-roles))))
2820	(and
2821	(not (set-exclusive-or (roles construct :revision start-revision)
2822	checked-roles))
2823	(= (length checked-roles) (length roles))
2824	(equivalent-typable-construct construct instance-of
2825	:start-revision start-revision)
2826	(equivalent-scopable-construct construct themes
2827	:start-revision start-revision))))
2828
2829
2830	(defmethod delete-construct :before ((construct AssociationC))
2831	(let ((roles-assocs-to-delete (slot-p construct 'roles)))
2832	(let ((all-roles (map 'list #'role roles-assocs-to-delete)))
2833	(dolist (role-assoc-to-delete roles-assocs-to-delete)
2834	(delete-construct role-assoc-to-delete))
2835	(dolist (candidate-to-delete all-roles)
2836	(unless (owned-p candidate-to-delete)
2837	(delete-construct candidate-to-delete)))
2838	(dolist (tm (slot-p construct 'in-topicmaps))
2839	(remove-association construct 'in-topicmaps tm)))))
2840
2841
2842	(defmethod owned-p ((construct AssociationC))
2843	(when (slot-p construct 'in-topicmaps)
2844	t))
2845
2846
2847	(defgeneric roles (construct &key revision)
2848	(:documentation "Returns all topics that correspond with the given revision
2849	as a scope for the given topic.")
2850	(:method ((construct AssociationC) &key (revision TM-REVISION))
2851	(let ((valid-associations
2852	(filter-slot-value-by-revision construct 'roles
2853	:start-revision revision)))
2854	(map 'list #'role valid-associations))))
2855
2856
2857	(defgeneric add-role (construct role &key revision)
2858	(:documentation "Adds the given role to the passed association-construct.")
2859	(:method ((construct AssociationC) (role RoleC)
2860	&key (revision TM-REVISION))
2861	(if (merge-if-equivalent role construct :revision revision)
2862	construct
2863	(let ((all-roles
2864	(map 'list #'role (slot-p construct 'roles))))
2865	(if (find role all-roles)
2866	(let ((role-assoc
2867	(loop for role-assoc in (slot-p construct 'roles)
2868	when (eql (role role-assoc) role)
2869	return role-assoc)))
2870	(add-to-version-history role-assoc :start-revision revision))
2871	(make-construct 'RoleAssociationC
2872	:role role
2873	:parent-construct construct
2874	:start-revision revision))
2875	(add-to-version-history construct :start-revision revision)
2876	construct))))
2877
2878
2879	(defgeneric private-delete-role (construct role &key revision)
2880	(:documentation "Deletes the passed role by marking it's association as
2881	deleted in the passed revision.")
2882	(:method ((construct AssociationC) (role RoleC)
2883	&key (revision (error (make-missing-argument-condition "From private-delete-role(): revision must be set" 'revision 'private-delete-role))))
2884	(let ((assoc-to-delete (loop for role-assoc in (slot-p construct 'roles)
2885	when (eql (role role-assoc) role)
2886	return role-assoc)))
2887	(when assoc-to-delete
2888	(mark-as-deleted assoc-to-delete :revision revision)
2889	construct))))
2890
2891
2892	(defgeneric delete-role (construct role &key revision)
2893	(:documentation "See private-delete-role but adds the parent association
2894	to the given version.")
2895	(:method ((construct AssociationC) (role RoleC)
2896	&key (revision (error (make-missing-argument-condition "From delete-role(): revision must be set" 'revision 'delete-role))))
2897	(when (private-delete-role construct role :revision revision)
2898	(add-to-version-history construct :start-revision revision)
2899	construct)))
2900
2901
2902	(defmethod in-topicmaps ((association AssociationC) &key (revision TM-REVISION))
2903	(filter-slot-value-by-revision association 'in-topicmaps :start-revision revision))
2904
2905
2906	;;; RoleC
2907	(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision)
2908	"Marks the last active relation between a role and its parent association
2909	as deleted."
2910	(declare (ignorable source-locator))
2911	(let ((owner (parent construct :revision 0)))
2912	(when owner
2913	;(private-delete-player construct (player construct :revision revision)
2914	;:revision revision)
2915	(private-delete-role owner construct :revision revision))))
2916
2917
2918	(defmethod marked-as-deleted-p ((construct RoleC))
2919	(unless (parent construct :revision 0)
2920	t))
2921
2922
2923	(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC)
2924	&key (revision TM-REVISION))
2925	(declare (integer revision))
2926	(let ((p-roles (roles parent-construct :revision revision)))
2927	(let ((self (find construct p-roles)))
2928	(if self
2929	self
2930	(let ((equal-role
2931	(remove-if #'null
2932	(map 'list
2933	#'(lambda(role)
2934	(strictly-equivalent-constructs
2935	role construct :revision revision))
2936	p-roles))))
2937	(when equal-role
2938	(first equal-role)))))))
2939
2940
2941	(defmethod delete-if-not-referenced ((construct RoleC))
2942	(let ((references (slot-p construct 'parent)))
2943	(when (or (not references)
2944	(and (= (length references) 1)
2945	(marked-as-deleted-p (first references))))
2946	(delete-construct construct))))
2947
2948
2949	(defmethod find-oldest-construct ((construct-1 RoleC) (construct-2 RoleC))
2950	(let ((vi-1 (find-version-info (slot-p construct-1 'parent)))
2951	(vi-2 (find-version-info (slot-p construct-2 'parent))))
2952	(cond ((not (or vi-1 vi-2))
2953	construct-1)
2954	((not vi-1)
2955	construct-2)
2956	((not vi-2)
2957	construct-1)
2958	((<= (start-revision vi-1) (start-revision vi-2))
2959	construct-1)
2960	(t
2961	construct-2))))
2962
2963
2964	(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC)
2965	&key (revision TM-REVISION))
2966	(declare (integer revision))
2967	(and (eql (instance-of construct-1 :revision revision)
2968	(instance-of construct-2 :revision revision))
2969	(eql (player construct-1 :revision revision)
2970	(player construct-2 :revision revision))))
2971
2972
2973	(defgeneric RoleC-p (class-symbol)
2974	(:documentation "Returns t if the passed symbol is equal to RoleC.")
2975	(:method ((class-symbol symbol))
2976	(eql class-symbol 'RoleC)))
2977
2978
2979	(defmethod equivalent-construct ((construct RoleC)
2980	&key (start-revision TM-REVISION)
2981	(player nil) (instance-of nil))
2982	"Roles are equal if their instance-of and player properties are equal."
2983	(declare (integer start-revision) (type (or null TopicC) player instance-of))
2984	;; item-identifiers and reifers are not checked because the equality have to
2985	;; be variafied without them
2986	(and (equivalent-typable-construct construct instance-of
2987	:start-revision start-revision)
2988	(eql player (player construct :revision start-revision))))
2989
2990
2991	(defmethod find-item-by-revision ((construct RoleC)
2992	(revision integer) &optional parent-construct)
2993	(if parent-construct
2994	(let ((parent-assoc
2995	(let ((assocs
2996	(remove-if
2997	#'null
2998	(map 'list #'(lambda(assoc)
2999	(when (eql (parent-construct assoc)
3000	parent-construct)
3001	assoc))
3002	(slot-p construct 'parent)))))
3003	(when assocs
3004	(first assocs)))))
3005	(when parent-assoc
3006	(cond ((= revision 0)
3007	(when
3008	(find-most-recent-revision parent-assoc)
3009	construct))
3010	(t
3011	(when (find-if
3012	#'(lambda(vi)
3013	(and (>= revision (start-revision vi))
3014	(or (< revision (end-revision vi))
3015	(= 0 (end-revision vi)))))
3016	(versions parent-assoc))
3017	construct)))))
3018	nil))
3019
3020
3021	(defmethod delete-construct :before ((construct RoleC))
3022	(dolist (role-assoc-to-delete (slot-p construct 'parent))
3023	(delete-construct role-assoc-to-delete))
3024	(dolist (player-assoc-to-delete (slot-p construct 'player))
3025	(delete-construct player-assoc-to-delete)))
3026
3027
3028	(defgeneric player-p (construct)
3029	(:documentation "Returns t if a player is set in this role.
3030	t is also returned if the player is markes-as-deleted.")
3031	(:method ((construct RoleC))
3032	(when (slot-p construct 'player)
3033	t)))
3034
3035
3036	(defmethod owned-p ((construct RoleC))
3037	(when (slot-p construct 'parent)
3038	t))
3039
3040
3041	(defmethod parent ((construct RoleC) &key (revision TM-REVISION))
3042	"Returns the construct's parent corresponding to the given revision."
3043	(let ((valid-associations
3044	(filter-slot-value-by-revision construct 'parent
3045	:start-revision revision)))
3046	(when valid-associations
3047	(parent-construct (first valid-associations)))))
3048
3049
3050	(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
3051	&key (revision TM-REVISION))
3052	(declare (integer revision))
3053	(let ((already-set-parent (parent construct :revision revision))
3054	(same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent)
3055	when (eql parent-construct (parent-construct parent-assoc))
3056	return parent-assoc)))
3057	(when (and already-set-parent
3058	(not (eql already-set-parent parent-construct)))
3059	(error (make-tm-reference-condition (format nil "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
3060	construct parent-construct already-set-parent)
3061	construct (parent construct :revision revision) parent-construct)))
3062	(let ((merged-role
3063	(merge-if-equivalent construct parent-construct :revision revision)))
3064	(if merged-role
3065	merged-role
3066	(progn
3067	(cond (already-set-parent
3068	(let ((parent-assoc
3069	(loop for parent-assoc in (slot-p construct 'parent)
3070	when (eql parent-construct
3071	(parent-construct parent-assoc))
3072	return parent-assoc)))
3073	(add-to-version-history parent-assoc
3074	:start-revision revision)))
3075	(same-parent-assoc
3076	(add-to-version-history same-parent-assoc
3077	:start-revision revision))
3078	(t
3079	(make-construct 'RoleAssociationC
3080	:role construct
3081	:parent-construct parent-construct
3082	:start-revision revision)))
3083	(add-to-version-history parent-construct :start-revision revision)
3084	construct)))))
3085
3086
3087	(defmethod private-delete-parent ((construct RoleC) (parent-construct AssociationC)
3088	&key (revision (error (make-missing-argument-condition "From private-delete-parent(): revision must be set" 'revision 'private-delete-parent))))
3089	(let ((assoc-to-delete
3090	(loop for parent-assoc in (slot-p construct 'parent)
3091	when (eql (parent-construct parent-assoc) parent-construct)
3092	return parent-assoc)))
3093	(when assoc-to-delete
3094	(mark-as-deleted assoc-to-delete :revision revision)
3095	construct)))
3096
3097
3098	(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
3099	&key (revision (error (make-missing-argument-condition "From delete-parent(): revision must be set" 'revision 'delete-parent))))
3100	(when (private-delete-parent construct parent-construct :revision revision)
3101	(add-to-version-history parent-construct :start-revision revision)
3102	construct))
3103
3104
3105	(defgeneric player (construct &key revision)
3106	(:documentation "Returns the construct's player corresponding to
3107	the given revision.")
3108	(:method ((construct RoleC) &key (revision TM-REVISION))
3109	(let ((valid-associations
3110	(filter-slot-value-by-revision construct 'player
3111	:start-revision revision)))
3112	(when valid-associations
3113	(player-topic (first valid-associations))))))
3114
3115
3116	(defgeneric add-player (construct player-topic &key revision)
3117	(:documentation "Adds a topic as a player to a role in the given revision.")
3118	(:method ((construct RoleC) (player-topic TopicC)
3119	&key (revision TM-REVISION))
3120	(let ((already-set-player (player construct :revision revision))
3121	(same-player-assoc
3122	(loop for player-assoc in (slot-p construct 'player)
3123	when (eql (player-topic player-assoc) player-topic)
3124	return player-assoc)))
3125	(when (and already-set-player
3126	(not (eql already-set-player player-topic)))
3127	(error (make-tm-reference-condition (format nil "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player)
3128	construct (player construct :revision revision) player-topic)))
3129	(cond (already-set-player
3130	(let ((player-assoc
3131	(loop for player-assoc in (slot-p construct 'player)
3132	when (eql player-topic (player-topic player-assoc))
3133	return player-assoc)))
3134	(add-to-version-history player-assoc :start-revision revision)))
3135	(same-player-assoc
3136	(add-to-version-history same-player-assoc :start-revision revision))
3137	(t
3138	(make-construct 'PlayerAssociationC
3139	:parent-construct construct
3140	:player-topic player-topic
3141	:start-revision revision))))
3142	construct))
3143
3144
3145	(defgeneric private-delete-player (construct player-topic &key revision)
3146	(:documentation "Deletes the passed topic as a player of the passed role
3147	object by marking its association-object as deleted.")
3148	(:method ((construct RoleC) (player-topic TopicC)
3149	&key (revision (error (make-missing-argument-condition "From private-delete-player(): revision must be set" 'revision 'private-delete-player))))
3150	(let ((assoc-to-delete
3151	(loop for player-assoc in (slot-p construct 'player)
3152	when (eql (parent-construct player-assoc) construct)
3153	return player-assoc)))
3154	(when assoc-to-delete
3155	(mark-as-deleted assoc-to-delete :revision revision)
3156	construct))))
3157
3158
3159	(defgeneric delete-player (construct player-topic &key revision)
3160	(:documentation "See delete-player but adds the parent role to
3161	the given version.")
3162	(:method ((construct RoleC) (player-topic TopicC)
3163	&key (revision (error (make-missing-argument-condition "From delete-player(): revision must be set" 'revision 'delete-player))))
3164	(when (private-delete-player construct player-topic :revision revision)
3165	(let ((assoc (parent construct :revision revision)))
3166	(when assoc
3167	(add-role assoc construct :revision revision)
3168	construct)))))
3169
3170
3171	;;; ReifiableConstructC
3172	(defmethod mark-as-deleted :around ((construct ReifiableConstructC)
3173	&key source-locator revision)
3174	"Marks all item-identifiers of a given reifiable-construct as deleted."
3175	(declare (ignorable source-locator))
3176	(call-next-method)
3177	(dolist (ii (item-identifiers construct :revision 0))
3178	(private-delete-item-identifier construct ii :revision revision)))
3179
3180
3181	(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)
3182	&key (revision TM-REVISION))
3183	(declare (integer revision))
3184	(dolist (id (get-all-identifiers-of-construct construct :revision revision))
3185	(when (>
3186	(length
3187	(delete-if-not #'(lambda(identifier)
3188	(or (typep identifier 'PersistentIdC)
3189	(typep identifier 'SubjectLocatorC)
3190	(typep identifier 'ItemIdentifierC)))
3191	(union
3192	(elephant:get-instances-by-value
3193	'ItemIdentifierC 'uri (uri id))
3194	(union
3195	(elephant:get-instances-by-value
3196	'PersistentIdC 'uri (uri id))
3197	(elephant:get-instances-by-value
3198	'SubjectLocatorC 'uri (uri id))))))
3199	1)
3200	(error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id))))))
3201
3202
3203	(defgeneric ReifiableConstructC-p (class-symbol)
3204	(:documentation "Returns t if the passed symbol is equal to ReifiableConstructC
3205	or one of its subtypes.")
3206	(:method ((class-symbol symbol))
3207	(or (eql class-symbol 'ReifiableconstructC)
3208	(TopicMapC-p class-symbol)
3209	(TopicC-p class-symbol)
3210	(AssociationC-p class-symbol)
3211	(RoleC-p class-symbol)
3212	(CharacteristicC-p class-symbol))))
3213
3214
3215	(defgeneric complete-reifiable (construct item-identifiers reifier
3216	&key start-revision)
3217	(:documentation "Adds all item-identifiers and the reifier to the passed
3218	construct.")
3219	(:method ((construct ReifiableConstructC) item-identifiers reifier
3220	&key (start-revision TM-REVISION))
3221	(declare (integer start-revision) (list item-identifiers)
3222	(type (or null TopicC) reifier))
3223	(let ((merged-construct construct))
3224	(dolist (ii item-identifiers)
3225	(setf merged-construct
3226	(add-item-identifier merged-construct ii
3227	:revision start-revision)))
3228	(when reifier
3229	(setf merged-construct (add-reifier merged-construct reifier
3230	:revision start-revision)))
3231	merged-construct)))
3232
3233
3234	(defgeneric equivalent-reifiable-construct (construct reifier item-identifiers
3235	&key start-revision)
3236	(:documentation "Returns t if the passed constructs are TMDM equal, i.e
3237	the reifiable construct have to share an item identifier
3238	or reifier.")
3239	(:method ((construct ReifiableConstructC) reifier item-identifiers
3240	&key (start-revision TM-REVISION))
3241	(declare (integer start-revision) (list item-identifiers)
3242	(type (or null TopicC) reifier))
3243	(or (and (reifier construct :revision start-revision)
3244	(eql reifier (reifier construct :revision start-revision)))
3245	(and (item-identifiers construct :revision start-revision)
3246	(intersection (item-identifiers construct :revision start-revision)
3247	item-identifiers)))))
3248
3249
3250	(defmethod delete-construct :before ((construct ReifiableConstructC))
3251	(let ((ii-assocs-to-delete (slot-p construct 'item-identifiers))
3252	(reifier-assocs-to-delete (slot-p construct 'reifier)))
3253	(let ((all-iis (map 'list #'identifier ii-assocs-to-delete)))
3254	(dolist (construct-to-delete (append ii-assocs-to-delete
3255	reifier-assocs-to-delete))
3256	(delete-construct construct-to-delete))
3257	(dolist (ii all-iis)
3258	(unless (owned-p ii)
3259	(delete-construct ii))))))
3260
3261
3262	(defgeneric item-identifiers (construct &key revision)
3263	(:documentation "Returns the ItemIdentifierC-objects that correspond
3264	with the passed construct and the passed version.")
3265	(:method ((construct ReifiableConstructC) &key (revision TM-REVISION))
3266	(let ((assocs (filter-slot-value-by-revision
3267	construct 'item-identifiers :start-revision revision)))
3268	(map 'list #'identifier assocs))))
3269
3270
3271	(defgeneric reifier (construct &key revision)
3272	(:documentation "Returns the reifier-topic that corresponds
3273	with the passed construct and the passed version.")
3274	(:method ((construct ReifiableConstructC) &key (revision TM-REVISION))
3275	(let ((assocs (filter-slot-value-by-revision
3276	construct 'reifier :start-revision revision)))
3277	(when assocs ;assocs must be nil or a list with exactly one item
3278	(reifier-topic (first assocs))))))
3279
3280
3281	(defgeneric add-item-identifier (construct item-identifier &key revision)
3282	(:documentation "Adds the passed item-identifier to the passed construct.
3283	If the item-identifier is already related with the passed
3284	construct a new revision is added.
3285	If the passed identifer already identifies another object
3286	the identified-constructs are merged.")
3287	(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
3288	&key (revision TM-REVISION))
3289	(let ((all-ids
3290	(map 'list #'identifier (slot-p construct 'item-identifiers)))
3291	(construct-to-be-merged
3292	(let ((id-owner (identified-construct item-identifier
3293	:revision revision)))
3294	(when (not (eql id-owner construct))
3295	id-owner))))
3296	(when (and construct-to-be-merged
3297	(not (eql (type-of construct-to-be-merged)
3298	(type-of construct))))
3299	(error (make-not-mergable-condition (format nil "From add-item-identifier(): ~a and ~a can't be merged since the identified-constructs are not of the same type"
3300	construct construct-to-be-merged)
3301	construct construct-to-be-merged)))
3302	(let ((merged-construct construct))
3303	(cond (construct-to-be-merged
3304	(setf merged-construct
3305	(merge-constructs construct construct-to-be-merged
3306	:revision revision)))
3307	((find item-identifier all-ids)
3308	(let ((ii-assoc
3309	(loop for ii-assoc in (slot-p construct 'item-identifiers)
3310	when (eql (identifier ii-assoc) item-identifier)
3311	return ii-assoc)))
3312	(add-to-version-history ii-assoc :start-revision revision)))
3313	(t
3314	(make-construct 'ItemIdAssociationC
3315	:parent-construct construct
3316	:identifier item-identifier
3317	:start-revision revision)))
3318	(add-version-info construct revision)
3319	merged-construct))))
3320
3321
3322	(defgeneric private-delete-item-identifier (construct item-identifier
3323	&key revision)
3324	(:documentation "Sets the association object between the passed constructs
3325	as mark-as-deleted.")
3326	(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
3327	&key (revision (error (make-missing-argument-condition "From private-delete-item-identifier(): revision must be set" 'revision 'private-delete-item-identifier))))
3328	(let ((assoc-to-delete (loop for ii-assoc in (slot-p construct 'item-identifiers)
3329	when (eql (identifier ii-assoc) item-identifier)
3330	return ii-assoc)))
3331	(when assoc-to-delete
3332	(mark-as-deleted assoc-to-delete :revision revision)
3333	construct))))
3334
3335
3336	(defgeneric delete-item-identifier (construct item-identifier
3337	&key revision)
3338	(:documentation "See private-delete-item-identifier but adds the parent
3339	construct to the given version.")
3340	(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
3341	&key (revision (error (make-missing-argument-condition "From delete-item-identifier(): revision must be set" 'revision 'delete-item-identifier))))
3342	(when (private-delete-item-identifier construct item-identifier
3343	:revision revision)
3344	(add-version-info construct revision)
3345	construct)))
3346
3347
3348	(defmethod any-id ((construct ReifiableConstructC) &key (revision TM-REVISION))
3349	(declare (Integer revision))
3350	(when-do iis (item-identifiers construct :revision revision)
3351	(uri (first iis))))
3352
3353
3354	(defgeneric add-reifier (construct reifier-topic &key revision)
3355	(:documentation "Adds the passed reifier-topic as reifier of the construct.
3356	If the construct is already reified by the given topic
3357	there only is added a new version-info.
3358	If the reifier-topic reifies already another construct
3359	the reified-constructs are merged.")
3360	(:method ((construct ReifiableConstructC) (reifier-topic TopicC)
3361	&key (revision TM-REVISION))
3362	(when (and (reified-construct reifier-topic :revision revision)
3363	(not (equivalent-constructs construct
3364	(reified-construct
3365	reifier-topic :revision revision))))
3366	(error (make-not-mergable-condition (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable"
3367	reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct)
3368	construct (reified-construct reifier-topic :revision revision))))
3369	(let ((merged-reifier-topic
3370	(if (reifier construct :revision revision)
3371	(merge-constructs (reifier construct :revision revision)
3372	reifier-topic :revision revision)
3373	reifier-topic)))
3374	(let ((all-constructs (map 'list #'reifiable-construct
3375	(slot-p reifier-topic 'reified-construct))))
3376	(let ((merged-construct construct))
3377	(cond ((reified-construct merged-reifier-topic :revision revision)
3378	(let ((merged-reified
3379	(merge-constructs
3380	(reified-construct merged-reifier-topic
3381	:revision revision) construct
3382	:revision revision)))
3383	(setf merged-construct merged-reified)))
3384	((find construct all-constructs)
3385	(let ((reifier-assoc
3386	(loop for reifier-assoc in
3387	(slot-p merged-reifier-topic 'reified-construct)
3388	when (eql (reifiable-construct reifier-assoc)
3389	construct)
3390	return reifier-assoc)))
3391	(add-to-version-history reifier-assoc
3392	:start-revision revision)))
3393	(t
3394	(make-construct 'ReifierAssociationC
3395	:reifiable-construct construct
3396	:reifier-topic merged-reifier-topic
3397	:start-revision revision)))
3398	(add-version-info construct revision)
3399	merged-construct)))))
3400
3401
3402	(defgeneric private-delete-reifier (construct reifier &key revision)
3403	(:documentation "Sets the association object between the passed constructs
3404	as mark-as-deleted.")
3405	(:method ((construct ReifiableConstructC) (reifier TopicC)
3406	&key (revision (error (make-missing-argument-condition "From private-delete-reifier(): revision must be set" 'revision 'private-delete-reifier))))
3407	(let ((assoc-to-delete (loop for reifier-assoc in (slot-p construct 'reifier)
3408	when (eql (reifier-topic reifier-assoc) reifier)
3409	return reifier-assoc)))
3410	(when assoc-to-delete
3411	(mark-as-deleted assoc-to-delete :revision revision)
3412	construct))))
3413
3414
3415	(defgeneric delete-reifier (construct reifier &key revision)
3416	(:documentation "See private-delete-reifier but adds the reified-construct
3417	to the given version.")
3418	(:method ((construct ReifiableConstructC) (reifier TopicC)
3419	&key (revision (error (make-missing-argument-condition "From delete-reifier(): revision must be set" 'revision 'delete-reifier))))
3420	(when (private-delete-reifier construct reifier :revision revision)
3421	(add-version-info construct revision)
3422	construct)))
3423
3424
3425	(defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC)
3426	&key (revision TM-REVISION))
3427	(declare (integer revision))
3428	(item-identifiers construct :revision revision))
3429
3430
3431	;;; TypableC
3432	(defgeneric TypableC-p (class-symbol)
3433	(:documentation "Returns t if the passed class is equal to TypableC or
3434	one of its subtypes.")
3435	(:method ((class-symbol symbol))
3436	(or (eql class-symbol 'TypableC)
3437	(AssociationC-p class-symbol)
3438	(RoleC-p class-symbol)
3439	(CharacteristicC-p class-symbol))))
3440
3441
3442	(defgeneric complete-typable (construct instance-of &key start-revision)
3443	(:documentation "Adds the passed instance-of to the given construct.")
3444	(:method ((construct TypableC) instance-of
3445	&key (start-revision TM-REVISION))
3446	(declare (integer start-revision) (type (or null TopicC) instance-of))
3447	(when instance-of
3448	(add-type construct instance-of :revision start-revision))
3449	construct))
3450
3451
3452	(defgeneric equivalent-typable-construct (construct instance-of
3453	&key start-revision)
3454	(:documentation "Returns t if the passed constructs are TMDM equal, i.e.
3455	the typable constructs have to own the same type.")
3456	(:method ((construct TypableC) instance-of &key (start-revision TM-REVISION))
3457	(declare (integer start-revision)
3458	(type (or null TopicC) instance-of))
3459	(eql (instance-of construct :revision start-revision) instance-of)))
3460
3461
3462	;;; ScopableC
3463	(defgeneric ScopableC-p (class-symbol)
3464	(:documentation "Returns t if the passed class is equal to ScopableC or
3465	one of its subtypes.")
3466	(:method ((class-symbol symbol))
3467	(or (eql class-symbol 'ScopableC)
3468	(AssociationC-p class-symbol)
3469	(CharacteristicC-p class-symbol))))
3470
3471
3472	(defgeneric complete-scopable (construct themes &key start-revision)
3473	(:documentation "Adds all passed themes to the given construct.")
3474	(:method ((construct ScopableC) (themes list)
3475	&key (start-revision TM-REVISION))
3476	(declare (integer start-revision))
3477	(dolist (theme themes)
3478	(add-theme construct theme :revision start-revision))
3479	construct))
3480
3481
3482	(defgeneric equivalent-scopable-construct (construct themes &key start-revision)
3483	(:documentation "Returns t if the passed constructs are TMDM equal, i.e.
3484	the scopable constructs have to own the same themes.")
3485	(:method ((construct ScopableC) themes &key (start-revision TM-REVISION))
3486	(declare (integer start-revision) (list themes))
3487	(not (set-exclusive-or (themes construct :revision start-revision)
3488	themes))))
3489
3490
3491	(defmethod delete-construct :before ((construct ScopableC))
3492	(dolist (scope-assoc-to-delete (slot-p construct 'themes))
3493	(delete-construct scope-assoc-to-delete)))
3494
3495
3496	(defgeneric themes (construct &key revision)
3497	(:documentation "Returns all topics that correspond with the given revision
3498	as a scope for the given topic.")
3499	(:method ((construct ScopableC) &key (revision TM-REVISION))
3500	(let ((valid-associations
3501	(filter-slot-value-by-revision construct 'themes
3502	:start-revision revision)))
3503	(map 'list #'theme-topic valid-associations))))
3504
3505
3506	(defgeneric add-theme (construct theme-topic &key revision)
3507	(:documentation "Adds the given theme-topic to the passed
3508	scopable-construct.")
3509	(:method ((construct ScopableC) (theme-topic TopicC)
3510	&key (revision TM-REVISION))
3511	(let ((all-themes
3512	(map 'list #'theme-topic (slot-p construct 'themes))))
3513	(if (find theme-topic all-themes)
3514	(let ((theme-assoc
3515	(loop for theme-assoc in (slot-p construct 'themes)
3516	when (eql (theme-topic theme-assoc) theme-topic)
3517	return theme-assoc)))
3518	(add-to-version-history theme-assoc :start-revision revision))
3519	(make-construct 'ScopeAssociationC
3520	:theme-topic theme-topic
3521	:scopable-construct construct
3522	:start-revision revision)))
3523	(when (typep construct 'VersionedConstructC)
3524	(add-to-version-history construct :start-revision revision))
3525	construct))
3526
3527
3528	(defgeneric private-delete-theme (construct theme-topic &key revision)
3529	(:documentation "Deletes the passed theme by marking it's association as
3530	deleted in the passed revision.")
3531	(:method ((construct ScopableC) (theme-topic TopicC)
3532	&key (revision (error (make-missing-argument-condition "From private-delete-theme(): revision must be set" 'revision 'private-delete-theme))))
3533	(let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes)
3534	when (eql (theme-topic theme-assoc) theme-topic)
3535	return theme-assoc)))
3536	(when assoc-to-delete
3537	(mark-as-deleted assoc-to-delete :revision revision)
3538	construct))))
3539
3540
3541	(defgeneric delete-theme (construct theme-topic &key revision)
3542	(:documentation "See private-delete-theme but adds the parent construct
3543	to the given version.")
3544	(:method ((construct ScopableC) (theme-topic TopicC)
3545	&key (revision (error (make-missing-argument-condition "From delete-theme(): revision must be set" 'revision 'delete-theme))))
3546	(when (private-delete-theme construct theme-topic :revision revision)
3547	(add-version-info construct revision)
3548	construct)))
3549
3550
3551	;;; TypableC
3552	(defmethod delete-construct :before ((construct TypableC))
3553	(dolist (type-assoc-to-delete (slot-p construct 'instance-of))
3554	(delete-construct type-assoc-to-delete)))
3555
3556
3557	(defgeneric instance-of-p (construct)
3558	(:documentation "Returns t if there is any type set in this object.
3559	t is also returned if the type is marked-as-deleted.")
3560	(:method ((construct TypableC))
3561	(when (slot-p construct 'instance-of)
3562	t)))
3563
3564
3565	(defgeneric instance-of (construct &key revision)
3566	(:documentation "Returns the type topic that is set on the passed
3567	revision.")
3568	(:method ((construct TypableC) &key (revision TM-REVISION))
3569	(let ((valid-associations
3570	(filter-slot-value-by-revision construct 'instance-of
3571	:start-revision revision)))
3572	(when valid-associations
3573	(type-topic (first valid-associations))))))
3574
3575
3576	(defgeneric add-type (construct type-topic &key revision)
3577	(:documentation "Add the passed type-topic as type to the given
3578	typed construct if there is no other type-topic
3579	set at the same revision.")
3580	(:method ((construct TypableC) (type-topic TopicC)
3581	&key (revision TM-REVISION))
3582	(let ((already-set-type (instance-of construct :revision revision))
3583	(same-type-assoc
3584	(loop for type-assoc in (slot-p construct 'instance-of)
3585	when (eql (type-topic type-assoc) type-topic)
3586	return type-assoc)))
3587	(when (and already-set-type
3588	(not (eql type-topic already-set-type)))
3589	(error (make-tm-reference-condition (format nil "From add-type(): ~a can't be typed by ~a since it is typed by ~a"
3590	construct type-topic already-set-type)
3591	construct (instance-of construct :revision revision) type-topic)))
3592	(cond (already-set-type
3593	(let ((type-assoc
3594	(loop for type-assoc in (slot-p construct 'instance-of)
3595	when (eql type-topic (type-topic type-assoc))
3596	return type-assoc)))
3597	(add-to-version-history type-assoc :start-revision revision)))
3598	(same-type-assoc
3599	(add-to-version-history same-type-assoc :start-revision revision))
3600	(t
3601	(make-construct 'TypeAssociationC
3602	:type-topic type-topic
3603	:typable-construct construct
3604	:start-revision revision))))
3605	(when (typep construct 'VersionedConstructC)
3606	(add-to-version-history construct :start-revision revision))
3607	construct))
3608
3609
3610	(defgeneric private-delete-type (construct type-topic &key revision)
3611	(:documentation "Deletes the passed type by marking it's association as
3612	deleted in the passed revision.")
3613	(:method ((construct TypableC) (type-topic TopicC)
3614	&key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type))))
3615	(let ((assoc-to-delete
3616	(loop for type-assoc in (slot-p construct 'instance-of)
3617	when (eql (type-topic type-assoc) type-topic)
3618	return type-assoc)))
3619	(when assoc-to-delete
3620	(mark-as-deleted assoc-to-delete :revision revision)
3621	construct))))
3622
3623
3624	(defgeneric delete-type (construct type-topic &key revision)
3625	(:documentation "See private-delete-type but adds the parent construct
3626	to the given version.")
3627	(:method ((construct TypableC) (type-topic TopicC)
3628	&key (revision (error (make-missing-argument-condition "From private-delete-type(): revision must be set" 'revision 'private-delete-type))))
3629	(when (private-delete-type construct type-topic :revision revision)
3630	(add-version-info construct revision)
3631	construct)))
3632
3633
3634	;;; TopicMapC
3635	(defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC)
3636	&key (revision TM-REVISION))
3637	"In this definition TopicMaps are alwayas equal,
3638	since item-identifiers and reifiers are not changing the result of
3639	the TMDM equality."
3640	(declare (ignorable revision))
3641	t)
3642
3643
3644	(defgeneric TopicMapC-p (class-symbol)
3645	(:documentation "Returns t if the passed symbol is equal to TopicMapC.")
3646	(:method ((class-symbol symbol))
3647	(eql class-symbol 'TopicMapC)))
3648
3649
3650	(defmethod equivalent-construct ((construct TopicMapC)
3651	&key (start-revision TM-REVISION)
3652	(reifier nil) (item-identifiers nil))
3653	"TopicMaps equality if they share the same item-identier or reifier."
3654	(declare (list item-identifiers) (integer start-revision)
3655	(type (or null TopicC) reifier))
3656	(equivalent-reifiable-construct construct reifier item-identifiers
3657	:start-revision start-revision))
3658
3659
3660	(defmethod delete-construct :before ((construct TopicMapC))
3661	(dolist (top (slot-p construct 'topics))
3662	(remove-association construct 'topics top))
3663	(dolist (assoc (slot-p construct 'associations))
3664	(remove-association construct 'associations assoc)))
3665
3666
3667	(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC))
3668	(add-association construct 'topics construct-to-add)
3669	construct-to-add)
3670
3671
3672	(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC))
3673	(add-association construct 'associations construct-to-add)
3674	construct-to-add)
3675
3676
3677	(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC))
3678	(remove-association construct 'topics construct-to-delete))
3679
3680
3681	(defmethod delete-from-tm ((construct TopicMapC)
3682	(construct-to-delete AssociationC))
3683	(remove-association construct 'associations construct-to-delete))
3684
3685
3686	(defgeneric in-topicmap (tm construct &key revision)
3687	(:documentation "Is a given construct (topic or assiciation) in this
3688	topic map?"))
3689
3690
3691	(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key
3692	(revision TM-REVISION))
3693	(when (find-item-by-revision top revision)
3694	(find (internal-id top) (topics tm) :test #'= :key #'internal-id)))
3695
3696
3697	(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC)
3698	&key (revision TM-REVISION))
3699	(when (find-item-by-revision ass revision)
3700	(find (internal-id ass) (associations tm) :test #'= :key #'internal-id)))
3701
3702
3703	;;; make-construct ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3704	(defun make-construct (class-symbol &rest args)
3705	"Creates a new topic map construct if necessary or
3706	retrieves an equivalent one if available and updates the revision
3707	history accordingly. Returns the object in question. Methods use
3708	specific keyword arguments for their purpose."
3709	(declare (symbol class-symbol))
3710	(when (and (or (VersionedConstructC-p class-symbol)
3711	(and (ReifiableConstructC-p class-symbol)
3712	(or (getf args :item-identifiers) (getf args :reifier))))
3713	(not (getf args :start-revision)))
3714	(error (make-missing-argument-condition "From make-construct(): start-revision must be set" 'start-revision 'make-construct)))
3715	(let ((construct
3716	(cond
3717	((PointerC-p class-symbol)
3718	(apply #'make-pointer class-symbol args))
3719	((CharacteristicC-p class-symbol)
3720	(apply #'make-characteristic class-symbol args))
3721	((TopicC-p class-symbol)
3722	(apply #'make-topic args))
3723	((TopicMapC-p class-symbol)
3724	(apply #'make-tm args))
3725	((RoleC-p class-symbol)
3726	(apply #'make-role args))
3727	((AssociationC-p class-symbol)
3728	(apply #'make-association args))
3729	((VersionedConstructC-p class-symbol)
3730	(apply #'make-instance class-symbol
3731	(rec-remf args :start-revision)))
3732	(t
3733	(apply #'make-instance class-symbol args))))
3734	(start-revision (or (getf args :start-revision) TM-REVISION)))
3735	(when (typep construct 'TypableC)
3736	(complete-typable construct (getf args :instance-of)
3737	:start-revision start-revision))
3738	(when (typep construct 'ScopableC)
3739	(complete-scopable construct (getf args :themes)
3740	:start-revision start-revision))
3741	(when (typep construct 'VersionedConstructC)
3742	(add-to-version-history construct :start-revision start-revision))
3743	(when (or (typep construct 'TopicC) (typep construct 'AssociationC))
3744	(dolist (tm (getf args :in-topicmaps))
3745	(add-to-tm tm construct)))
3746	(if (typep construct 'ReifiableConstructC)
3747	(complete-reifiable construct (getf args :item-identifiers)
3748	(getf args :reifier) :start-revision start-revision)
3749	construct)))
3750
3751
3752	(defun make-association (&rest args)
3753	"Returns an association object. If the association has already existed the
3754	existing one is returned otherwise a new one is created.
3755	This function exists only for being used by make-construct!"
3756	(let ((instance-of (getf args :instance-of))
3757	(start-revision (getf args :start-revision))
3758	(themes (getf args :themes))
3759	(roles (getf args :roles)))
3760	(when (and (or roles instance-of themes)
3761	(not start-revision))
3762	(error (make-missing-argument-condition "From make-association(): start-revision must be set" 'start-revision 'make-association)))
3763	(let ((association
3764	(let ((existing-associations
3765	(remove-if
3766	#'null
3767	(map 'list #'(lambda(existing-association)
3768	(when (equivalent-construct
3769	existing-association
3770	:start-revision start-revision
3771	:roles roles :themes themes
3772	:instance-of instance-of)
3773	existing-association))
3774	(get-all-associations nil)))))
3775	(cond ((> (length existing-associations) 1)
3776	(merge-all-constructs existing-associations
3777	:revision start-revision))
3778	(existing-associations
3779	(first existing-associations))
3780	(t
3781	(make-instance 'AssociationC))))))
3782	(dolist (role-plist roles)
3783	(add-role association
3784	(apply #'make-construct 'RoleC
3785	(append role-plist (list :parent association)))
3786	:revision (getf role-plist :start-revision)))
3787	association)))
3788
3789
3790	(defun make-role (&rest args)
3791	"Returns a role object. If the role has already existed the
3792	existing one is returned otherwise a new one is created.
3793	This function exists only for being used by make-construct!"
3794	(let ((parent (getf args :parent))
3795	(instance-of (getf args :instance-of))
3796	(player (getf args :player))
3797	(start-revision (getf args :start-revision)))
3798	(when (and (or instance-of player parent)
3799	(not start-revision))
3800	(error (make-missing-argument-condition "From make-role(): start-revision must be set" 'start-revision 'make-role)))
3801	(let ((role
3802	(let ((existing-roles
3803	(when parent
3804	(remove-if
3805	#'null
3806	(map 'list #'(lambda(existing-role)
3807	(when (equivalent-construct
3808	existing-role
3809	:start-revision start-revision
3810	:player player
3811	:instance-of instance-of)
3812	existing-role))
3813	(map 'list #'role (slot-p parent 'roles)))))))
3814	(if (and existing-roles
3815	(or (eql parent (parent (first existing-roles)
3816	:revision start-revision))
3817	(not (parent (first existing-roles)
3818	:revision start-revision))))
3819	(progn
3820	(add-role parent (first existing-roles)
3821	:revision start-revision)
3822	(first existing-roles))
3823	(make-instance 'RoleC)))))
3824	(when player
3825	(add-player role player :revision start-revision))
3826	(when parent
3827	(add-parent role parent :revision start-revision))
3828	role)))
3829
3830
3831	(defun make-tm (&rest args)
3832	"Returns a topic map object. If the topic map has already existed the
3833	existing one is returned otherwise a new one is created.
3834	This function exists only for being used by make-construct!"
3835	(let ((item-identifiers (getf args :item-identifiers))
3836	(reifier (getf args :reifier))
3837	(topics (getf args :topics))
3838	(assocs (getf args :associations))
3839	(start-revision (getf args :start-revision)))
3840	(when (and (or item-identifiers reifier)
3841	(not start-revision))
3842	(error (make-missing-argument-condition "From make-tm(): start-revision must be set" 'start-revision 'make-tm)))
3843	(let ((tm
3844	(let ((existing-tms
3845	(remove-if
3846	#'null
3847	(map 'list #'(lambda(existing-tm)
3848	(when (equivalent-construct
3849	existing-tm
3850	:item-identifiers item-identifiers
3851	:reifier reifier)
3852	existing-tm))
3853	(get-all-tms start-revision)))))
3854	(cond ((> (length existing-tms) 1)
3855	(merge-all-constructs existing-tms :revision start-revision))
3856	(existing-tms
3857	(first existing-tms))
3858	(t
3859	(make-instance 'TopicMapC))))))
3860	(dolist (top-or-assoc (union topics assocs))
3861	(add-to-tm tm top-or-assoc))
3862	tm)))
3863
3864
3865	(defun make-topic (&rest args)
3866	"Returns a topic object. If the topic has already existed the existing one is
3867	returned otherwise a new one is created.
3868	This function exists only for being used by make-construct!"
3869	(let ((start-revision (getf args :start-revision))
3870	(psis (getf args :psis))
3871	(locators (getf args :locators))
3872	(item-identifiers (getf args :item-identifiers))
3873	(topic-identifiers (getf args :topic-identifiers))
3874	(names (getf args :names))
3875	(occurrences (getf args :occurrences))
3876	(reified-construct (getf args :refied-construct)))
3877	(when (and (or psis locators item-identifiers topic-identifiers
3878	names occurrences)
3879	(not start-revision))
3880	(error (make-missing-argument-condition "From make-topic(): start-revision must be set" 'start-revision 'make-topic)))
3881	(let ((topic
3882	(let ((existing-topics
3883	(remove-if
3884	#'null
3885	(map 'list #'(lambda(existing-topic)
3886	(when (equivalent-construct
3887	existing-topic
3888	:start-revision start-revision
3889	:psis psis :locators locators
3890	:item-identifiers item-identifiers
3891	:topic-identifiers topic-identifiers)
3892	existing-topic))
3893	(get-all-topics start-revision)))))
3894	(cond ((> (length existing-topics) 1)
3895	(merge-all-constructs existing-topics :revision start-revision))
3896	(existing-topics
3897	(first existing-topics))
3898	(t
3899	(make-instance 'TopicC))))))
3900	(let ((merged-topic topic))
3901	(dolist (tid topic-identifiers)
3902	(setf merged-topic (add-topic-identifier merged-topic tid
3903	:revision start-revision)))
3904	(dolist (psi psis)
3905	(setf merged-topic (add-psi merged-topic psi
3906	:revision start-revision)))
3907	(dolist (locator locators)
3908	(setf merged-topic (add-locator merged-topic locator
3909	:revision start-revision)))
3910	(dolist (name names)
3911	(setf merged-topic (add-name merged-topic name
3912	:revision start-revision)))
3913	(dolist (occ occurrences)
3914	(add-occurrence merged-topic occ :revision start-revision))
3915	(when reified-construct
3916	(add-reified-construct merged-topic reified-construct
3917	:revision start-revision))
3918	merged-topic))))
3919
3920
3921	(defun make-characteristic (class-symbol &rest args)
3922	"Returns a characteristic object with the passed parameters.
3923	If an equivalent construct has already existed this one is returned.
3924	To check if there is existing an equivalent construct the parameter
3925	parent-construct must be set.
3926	This function only exists for being used by make-construct!"
3927	(let ((charvalue (or (getf args :charvalue) ""))
3928	(start-revision (getf args :start-revision))
3929	(datatype (or (getf args :datatype) xml-string))
3930	(instance-of (getf args :instance-of))
3931	(themes (getf args :themes))
3932	(variants (getf args :variants))
3933	(parent (getf args :parent)))
3934	(when (and (or instance-of themes variants parent)
3935	(not start-revision))
3936	(error (make-missing-argument-condition "From make-characteristic(): start-revision must be set" 'start-revision 'make-characgteristic)))
3937	(let ((characteristic
3938	(let ((existing-characteristics
3939	(when parent
3940	(remove-if
3941	#'null
3942	(map 'list #'(lambda(existing-characteristic)
3943	(when (equivalent-construct
3944	existing-characteristic
3945	:start-revision start-revision
3946	:datatype datatype :variants variants
3947	:charvalue charvalue :themes themes
3948	:instance-of instance-of)
3949	existing-characteristic))
3950	(get-all-characteristics parent class-symbol))))))
3951	(if (and existing-characteristics
3952	(or (eql parent (parent (first existing-characteristics)
3953	:revision start-revision))
3954	(not (parent (first existing-characteristics)
3955	:revision start-revision))))
3956	(progn
3957	(add-characteristic parent (first existing-characteristics)
3958	:revision start-revision)
3959	(first existing-characteristics))
3960	(make-instance class-symbol :charvalue charvalue
3961	:datatype datatype)))))
3962	(when (typep characteristic 'NameC)
3963	(complete-name characteristic variants :start-revision start-revision))
3964	(when parent
3965	(add-parent characteristic parent :revision start-revision))
3966	characteristic)))
3967
3968
3969	(defun make-pointer (class-symbol &rest args)
3970	"Returns a pointer object with the specified parameters.
3971	If an equivalen construct has already existed this one is returned.
3972	This function only exists for beoing used by make-construct!"
3973	(let ((uri (getf args :uri))
3974	(xtm-id (getf args :xtm-id))
3975	(start-revision (getf args :start-revision))
3976	(identified-construct (getf args :identified-construct))
3977	(err "From make-pointer(): "))
3978	(when (and identified-construct (not start-revision))
3979	(error (make-missing-argument-condition (format nil "~astart-revision must be set" err) 'start-revision 'make-pointer)))
3980	(unless uri
3981	(error (make-missing-argument-condition (format nil "~auri must be set" err) 'uri 'make-pointer)))
3982	(when (and (TopicIdentificationC-p class-symbol)
3983	(not xtm-id))
3984	(error (make-missing-argument-condition (format nil "~axtm-id must be set" err) 'xtm-id 'make-pointer)))
3985	(when (and uri (IdentifierC-p class-symbol))
3986	(let ((existing-identifier
3987	(elephant:get-instance-by-value class-symbol 'uri uri)))
3988	(when (and existing-identifier (not (typep existing-identifier class-symbol)))
3989	(error (make-duplicate-identifier-condition (format nil "From make-pointer(): cannot create ~a with the uri ~a, since the identifier ~a with this uri already exists (merging is only supported for identifiers of the same type)" class-symbol uri existing-identifier) uri)))))
3990	(let ((identifier
3991	(let ((existing-pointer
3992	(remove-if
3993	#'null
3994	(map 'list
3995	#'(lambda(existing-pointer)
3996	(when (and (typep existing-pointer class-symbol)
3997	(equivalent-construct existing-pointer
3998	:uri uri
3999	:xtm-id xtm-id))
4000	existing-pointer))
4001	(elephant:get-instances-by-value class-symbol 'd::uri uri)))))
4002	(if existing-pointer
4003	(first existing-pointer)
4004	(make-instance class-symbol :uri uri :xtm-id xtm-id)))))
4005	(when identified-construct
4006	(cond ((TopicIdentificationC-p class-symbol)
4007	(add-topic-identifier identified-construct identifier
4008	:revision start-revision))
4009	((PersistentIdC-p class-symbol)
4010	(add-psi identified-construct identifier :revision start-revision))
4011	((ItemIdentifierC-p class-symbol)
4012	(add-item-identifier identified-construct identifier
4013	:revision start-revision))
4014	((SubjectLocatorC-p class-symbol)
4015	(add-locator identified-construct identifier
4016	:revision start-revision))))
4017	identifier)))
4018
4019
4020	;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4021	(defgeneric move-identifiers (source destination &key revision)
4022	(:documentation "Sets all identifiers as mark as deleted in the given
4023	version and adds the marked identifiers to the
4024	destination construct."))
4025
4026
4027	(defmethod move-identifiers ((source ReifiableConstructC)
4028	(destination ReifiableConstructC)
4029	&key (revision TM-REVISION))
4030	(declare (integer revision))
4031	(let ((iis (item-identifiers source :revision revision)))
4032	(dolist (ii iis)
4033	(private-delete-item-identifier source ii :revision revision)
4034	(add-item-identifier destination ii :revision revision))
4035	iis))
4036
4037
4038	(defmethod move-identifiers ((source TopicC) (destination TopicC)
4039	&key (revision TM-REVISION))
4040	(declare (integer revision))
4041	(let ((iis (call-next-method))
4042	(tids (topic-identifiers source :revision revision))
4043	(psis (psis source :revision revision))
4044	(sls (locators source :revision revision)))
4045	(dolist (tid tids)
4046	(private-delete-topic-identifier source tid :revision revision)
4047	(add-topic-identifier destination tid :revision revision))
4048	(dolist (psi psis)
4049	(private-delete-psi source psi :revision revision)
4050	(add-psi destination psi :revision revision))
4051	(dolist (sl sls)
4052	(private-delete-locator source sl :revision revision)
4053	(add-locator destination sl :revision revision))
4054	(append tids iis psis sls)))
4055
4056
4057	(defgeneric move-referenced-constructs (source destination &key revision)
4058	(:documentation "Moves all referenced constructs in the given version from
4059	the source TM-construct to the destination TM-construct."))
4060
4061
4062	(defmethod move-referenced-constructs ((source ReifiableConstructC)
4063	(destination ReifiableConstructC)
4064	&key (revision TM-REVISION))
4065	(declare (integer revision))
4066	(remove-if
4067	#'null
4068	(append
4069	(move-identifiers source destination :revision revision)
4070	(let ((source-reifier (reifier source :revision revision))
4071	(destination-reifier (reifier destination :revision revision)))
4072	(let ((result
4073	(cond ((and source-reifier destination-reifier)
4074	(private-delete-reifier (reified-construct source-reifier
4075	:revision revision)
4076	source-reifier :revision revision)
4077	(private-delete-reifier (reified-construct destination-reifier
4078	:revision revision)
4079	destination-reifier :revision revision)
4080	(let ((merged-reifier
4081	(merge-constructs source-reifier destination-reifier
4082	:revision revision)))
4083	(add-reifier destination merged-reifier :revision revision)
4084	merged-reifier))
4085	(source-reifier
4086	(private-delete-reifier (reified-construct source-reifier
4087	:revision revision)
4088	source-reifier :revision revision)
4089	(add-reifier destination source-reifier :revision revision)
4090	source-reifier)
4091	(destination-reifier
4092	(add-reifier destination destination-reifier :revision revision)
4093	nil))))
4094	(when result
4095	(list result)))))))
4096
4097
4098	(defmethod move-referenced-constructs ((source NameC) (destination NameC)
4099	&key (revision TM-REVISION))
4100	(declare (integer revision))
4101	(append (call-next-method)
4102	(move-variants source destination :revision revision)))
4103
4104
4105	(defmethod move-referenced-constructs ((source TopicC) (destination TopicC)
4106	&key (revision TM-REVISION))
4107	(let ((roles (player-in-roles source :revision revision))
4108	(scopables (used-as-theme source :revision revision))
4109	(typables (used-as-type source :revision revision))
4110	(ids (move-identifiers source destination :revision revision)))
4111	(dolist (role roles)
4112	(private-delete-player role source :revision revision)
4113	(add-player role destination :revision revision))
4114	(dolist (scopable scopables)
4115	(private-delete-theme scopable source :revision revision)
4116	(add-theme scopable destination :revision revision))
4117	(dolist (typable typables)
4118	(private-delete-type typable source :revision revision)
4119	(add-type typable destination :revision revision))
4120	(remove-if #'null (append roles scopables typables ids))))
4121
4122
4123	(defgeneric move-reified-construct (source destination &key revision)
4124	(:documentation "Moves the refied TM-construct from the source topic
4125	to the given destination topic.")
4126	(:method ((source TopicC) (destination TopicC) &key (revision TM-REVISION))
4127	(declare (integer revision))
4128	(let ((source-reified (reified-construct source :revision revision))
4129	(destination-reified (reified-construct destination
4130	:revision revision)))
4131	(when (and source-reified destination-reified
4132	(not (eql (type-of source-reified)
4133	(type-of destination-reified))))
4134	(error (make-not-mergable-condition (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a"
4135	source destination source-reified destination-reified)
4136	source destination)))
4137	(cond ((and source-reified destination-reified)
4138	(private-delete-reifier source-reified source :revision revision)
4139	(private-delete-reifier destination-reified destination :revision revision)
4140	(let ((merged-reified
4141	(merge-constructs source-reified destination-reified
4142	:revision revision)))
4143	(add-reifier merged-reified destination :revision revision)
4144	merged-reified))
4145	(source-reified
4146	(private-delete-reifier source source-reified :revision revision)
4147	(add-reifier source-reified destination :revision revision)
4148	source-reified)
4149	(destination-reified
4150	(add-reifier destination-reified destination :revision revision)
4151	destination-reified)))))
4152
4153
4154	(defgeneric move-occurrences (source destination &key revision)
4155	(:documentation "Moves all occurrences from the source topic to the
4156	destination topic. If occurrences are TMDM equal
4157	they are merged, i.e. one is marked-as-deleted.")
4158	(:method ((source TopicC) (destination TopicC) &key (revision TM-REVISION))
4159	(declare (integer revision))
4160	(let ((occs-to-move (occurrences source :revision revision)))
4161	(dolist (occ occs-to-move)
4162	(private-delete-occurrence source occ :revision revision)
4163	(let ((equivalent-occ
4164	(find-if #'(lambda (destination-occ)
4165	(when
4166	(strictly-equivalent-constructs
4167	occ destination-occ :revision revision)
4168	destination-occ))
4169	(occurrences destination :revision revision))))
4170	(if equivalent-occ
4171	(progn
4172	(add-occurrence destination equivalent-occ :revision revision)
4173	(move-referenced-constructs occ equivalent-occ
4174	:revision revision))
4175	(add-occurrence destination occ :revision revision))))
4176	occs-to-move)))
4177
4178
4179	(defgeneric move-variants (source destination &key revision)
4180	(:documentation "Moves all variants from the source name to the destination
4181	name. If any variants are TMDM equal they are merged -->
4182	i.e. one of the variants is marked-as-deleted.")
4183	(:method ((source NameC) (destination NameC) &key (revision TM-REVISION))
4184	(declare (integer revision))
4185	(let ((vars-to-move (variants source :revision revision)))
4186	(dolist (var vars-to-move)
4187	(private-delete-variant source var :revision revision)
4188	(let ((equivalent-var
4189	(find-if #'(lambda (destination-var)
4190	(when
4191	(strictly-equivalent-constructs
4192	var destination-var :revision revision)
4193	destination-var))
4194	(variants destination :revision revision))))
4195	(if equivalent-var
4196	(progn
4197	(add-variant destination equivalent-var :revision revision)
4198	(move-referenced-constructs var equivalent-var
4199	:revision revision))
4200	(add-variant destination var :revision revision))))
4201	vars-to-move)))
4202
4203
4204	(defgeneric move-names (source destination &key revision)
4205	(:documentation "Moves all names from the source topic to the destination
4206	topic. If any names are equal they are merged, i.e.
4207	one of the names is marked-as-deleted.")
4208	(:method ((source TopicC) (destination TopicC) &key (revision TM-REVISION))
4209	(declare (integer revision))
4210	(let ((names-to-move (names source :revision revision)))
4211	(dolist (name names-to-move)
4212	(private-delete-name source name :revision revision)
4213	(let ((equivalent-name
4214	(find-if #'(lambda (destination-name)
4215	(when
4216	(strictly-equivalent-constructs
4217	name destination-name :revision revision)
4218	destination-name))
4219	(names destination :revision revision))))
4220	(if equivalent-name
4221	(progn
4222	(add-name destination equivalent-name :revision revision)
4223	(move-referenced-constructs name equivalent-name
4224	:revision revision))
4225	(add-name destination name :revision revision))))
4226	names-to-move)))
4227
4228
4229	(defun merge-changed-constructs (older-topic &key (revision TM-REVISION))
4230	(declare (TopicC older-topic))
4231	(dolist (construct (append (used-as-type older-topic :revision revision)
4232	(used-as-theme older-topic :revision revision)
4233	(player-in-roles older-topic :revision revision)))
4234	(let ((parent (when (or (typep construct 'RoleC)
4235	(typep construct 'CharacteristicC))
4236	(parent construct :revision revision))))
4237	(when parent
4238	(let ((all-other (cond ((typep construct 'OccurrenceC)
4239	(occurrences parent :revision revision))
4240	((typep construct 'NameC)
4241	(names parent :revision revision))
4242	((typep construct 'VariantC)
4243	(variants parent :revision revision))
4244	((typep construct 'RoleC)
4245	(roles parent :revision revision)))))
4246	(let ((all-equivalent
4247	(remove-if
4248	#'null
4249	(map 'list #'(lambda(other)
4250	(when (strictly-equivalent-constructs
4251	construct other :revision revision)
4252	other))
4253	all-other))))
4254	(when all-equivalent
4255	(merge-all-constructs (append all-equivalent (list construct))
4256	:revision revision)))))))
4257	(merge-changed-associations older-topic :revision revision))
4258
4259
4260	(defun merge-changed-associations (older-topic &key (revision TM-REVISION))
4261	"Merges all associations that became TMDM-equal since two referenced topics
4262	were merged, e.g. the association types."
4263	(declare (TopicC older-topic))
4264	(let ((all-assocs
4265	(remove-duplicates
4266	(append
4267	(remove-if
4268	#'null
4269	(map 'list #'(lambda(role)
4270	(parent role :revision revision))
4271	(player-in-roles older-topic :revision revision)))
4272	(remove-if
4273	#'null
4274	(map
4275	'list #'(lambda(constr)
4276	(when (typep constr 'AssociationC)
4277	constr))
4278	(append (used-as-type older-topic :revision revision)
4279	(used-as-theme older-topic :revision revision))))))))
4280	(dolist (assoc all-assocs)
4281	(let ((all-equivalent
4282	(remove-if
4283	#'null
4284	(map 'list #'(lambda(db-assoc)
4285	(when (strictly-equivalent-constructs
4286	assoc db-assoc :revision revision)
4287	db-assoc))
4288	(get-all-associations nil)))))
4289	(when all-equivalent
4290	(merge-all-constructs (append all-equivalent (list assoc))
4291	:revision revision))))))
4292
4293
4294	(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC)
4295	&key (revision TM-REVISION))
4296	(if (eql construct-1 construct-2)
4297	construct-1
4298	(let ((older-topic (find-oldest-construct construct-1 construct-2)))
4299	(let ((newer-topic (if (eql older-topic construct-1)
4300	construct-2
4301	construct-1)))
4302	(dolist (tm (in-topicmaps newer-topic :revision revision))
4303	(add-to-tm tm older-topic))
4304	(move-names newer-topic older-topic :revision revision)
4305	(move-occurrences newer-topic older-topic :revision revision)
4306	(move-referenced-constructs newer-topic older-topic :revision revision)
4307	(move-reified-construct newer-topic older-topic :revision revision)
4308	(merge-changed-constructs older-topic :revision revision)
4309	(mark-as-deleted newer-topic :revision revision :source-locator nil)
4310	(when (exist-in-version-history-p newer-topic)
4311	(delete-construct newer-topic))
4312	older-topic))))
4313
4314
4315	(defmethod merge-constructs ((construct-1 CharacteristicC)
4316	(construct-2 CharacteristicC)
4317	&key (revision TM-REVISION))
4318	(declare (integer revision))
4319	(if (eql construct-1 construct-2)
4320	construct-1
4321	(let ((older-char (find-oldest-construct construct-1 construct-2)))
4322	(let ((newer-char (if (eql older-char construct-1)
4323	construct-2
4324	construct-1)))
4325	(let ((parent-1 (parent older-char :revision revision))
4326	(parent-2 (parent newer-char :revision revision)))
4327	(unless (strictly-equivalent-constructs construct-1 construct-2
4328	:revision revision)
4329	(error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
4330	construct-1 construct-2)))
4331	(cond ((and parent-1 (eql parent-1 parent-2))
4332	(move-referenced-constructs newer-char older-char
4333	:revision revision)
4334	(private-delete-characteristic parent-2 newer-char
4335	:revision revision)
4336	(let ((c-assoc
4337	(find-if
4338	#'(lambda(c-assoc)
4339	(and (eql (characteristic c-assoc) older-char)
4340	(eql (parent-construct c-assoc) parent-1)))
4341	(cond ((typep older-char 'OccurrenceC)
4342	(slot-p parent-1 'occurrences))
4343	((typep older-char 'NameC)
4344	(slot-p parent-1 'names))
4345	((typep older-char 'VariantC)
4346	(slot-p parent-1 'variants))))))
4347	(add-to-version-history c-assoc :start-revision revision))
4348	older-char)
4349	((and parent-1 parent-2)
4350	(let ((active-parent (merge-constructs parent-1 parent-2
4351	:revision revision)))
4352	(let ((found-older-char
4353	(cond ((typep older-char 'OccurrenceC)
4354	(find older-char
4355	(occurrences
4356	active-parent :revision revision)))
4357	((typep older-char 'NameC)
4358	(find older-char
4359	(names
4360	active-parent :revision revision)))
4361	((typep older-char 'VariantC)
4362	(find-if
4363	#'(lambda(name)
4364	(find older-char
4365	(variants name
4366	:revision revision)))
4367	(if (parent active-parent :revision revision)
4368	(names (parent active-parent :revision revision)
4369	:revision revision)
4370	(list active-parent)))))))
4371	(if found-older-char
4372	older-char
4373	newer-char))))
4374	((or parent-1 parent-2)
4375	(let ((dst (if parent-1 older-char newer-char))
4376	(src (if parent-1 newer-char older-char)))
4377	(move-referenced-constructs src dst :revision revision)
4378	(delete-if-not-referenced src)
4379	dst))
4380	(t
4381	(move-referenced-constructs newer-char older-char
4382	:revision revision)
4383	(delete-if-not-referenced newer-char)
4384	older-char)))))))
4385
4386
4387	(defmethod merge-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC)
4388	&key (revision TM-REVISION))
4389	(declare (integer revision))
4390	(if (eql construct-1 construct-2)
4391	construct-1
4392	(let ((older-tm (find-oldest-construct construct-1 construct-2)))
4393	(let ((newer-tm (if (eql older-tm construct-1)
4394	construct-2
4395	construct-1)))
4396	(move-referenced-constructs newer-tm older-tm :revision revision)
4397	(dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm)))
4398	(add-to-tm older-tm top-or-assoc))
4399	(add-to-version-history older-tm :start-revision revision)
4400	(mark-as-deleted newer-tm :revision revision)
4401	(when (exist-in-version-history-p newer-tm)
4402	(delete-construct newer-tm))
4403	older-tm))))
4404
4405
4406	(defmethod merge-constructs ((construct-1 AssociationC) (construct-2 AssociationC)
4407	&key revision)
4408	(declare (integer revision))
4409	(if (eql construct-1 construct-2)
4410	construct-1
4411	(let ((older-assoc (find-oldest-construct construct-1 construct-2)))
4412	(let ((newer-assoc (if (eql older-assoc construct-1)
4413	construct-2
4414	construct-1)))
4415	;(unless (strictly-equivalent-constructs construct-1 construct-2
4416	; :revision revision)
4417	;;associations that have different roles can be although merged, e.g.
4418	;;two roles are in two different association objects references
4419	;;the same item-identifier or reifier
4420	(when (or (set-exclusive-or (themes construct-1 :revision revision)
4421	(themes construct-2 :revision revision))
4422	(not (eql (instance-of construct-1 :revision revision)
4423	(instance-of construct-2 :revision revision))))
4424	(error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
4425	construct-1 construct-2)))
4426	(dolist (tm (in-topicmaps newer-assoc :revision revision))
4427	(add-to-tm tm older-assoc))
4428	(private-delete-type newer-assoc (instance-of newer-assoc :revision revision)
4429	:revision revision)
4430	(move-referenced-constructs newer-assoc older-assoc :revision revision)
4431	(dolist (newer-role (roles newer-assoc :revision revision))
4432	(let ((equivalent-role
4433	(find-if #'(lambda(older-role)
4434	(strictly-equivalent-constructs
4435	older-role newer-role :revision revision))
4436	(roles older-assoc :revision revision))))
4437	(when equivalent-role
4438	(move-referenced-constructs newer-role equivalent-role
4439	:revision revision))
4440	(private-delete-role newer-assoc newer-role :revision revision)
4441	(add-role older-assoc (if equivalent-role
4442	equivalent-role
4443	newer-role)
4444	:revision revision)))
4445	(mark-as-deleted newer-assoc :revision revision)
4446	(when (exist-in-version-history-p newer-assoc)
4447	(delete-construct newer-assoc))
4448	older-assoc))))
4449
4450
4451	(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC)
4452	&key (revision TM-REVISION))
4453	(declare (integer TM-REVISION))
4454	(if (eql construct-1 construct-2)
4455	construct-1
4456	(let ((older-role (find-oldest-construct construct-1 construct-2)))
4457	(let ((newer-role (if (eql older-role construct-1)
4458	construct-2
4459	construct-1)))
4460	(unless (strictly-equivalent-constructs construct-1 construct-2
4461	:revision revision)
4462	(error (make-not-mergable-condition (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2)
4463	construct-1 construct-2)))
4464	(let ((parent-1 (parent older-role :revision revision))
4465	(parent-2 (parent newer-role :revision revision)))
4466	(cond ((and parent-1 (eql parent-1 parent-2))
4467	(move-referenced-constructs newer-role older-role
4468	:revision revision)
4469	(private-delete-role parent-2 newer-role :revision revision)
4470	(let ((r-assoc
4471	(find-if
4472	#'(lambda(r-assoc)
4473	(and (eql (role r-assoc) older-role)
4474	(eql (parent-construct r-assoc) parent-1)))
4475	(slot-p parent-1 'roles))))
4476	(add-to-version-history r-assoc :start-revision revision)
4477	older-role))
4478	((and parent-1 parent-2)
4479	(let ((active-assoc (merge-constructs parent-1 parent-2
4480	:revision revision)))
4481	(if (find older-role (roles active-assoc
4482	:revision revision))
4483	older-role
4484	newer-role)))
4485	((or parent-1 parent-2)
4486	(let ((dst (if parent-1 older-role newer-role))
4487	(src (if parent-1 newer-role older-role)))
4488	(move-referenced-constructs src dst :revision revision)
4489	(delete-if-not-referenced src)
4490	dst))
4491	(t
4492	(move-referenced-constructs newer-role older-role
4493	:revision revision)
4494	(delete-if-not-referenced newer-role)
4495	older-role)))))))
4496
4497
4498	(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC)
4499	&key (revision TM-REVISION))
4500	(declare (integer revision))
4501	(let ((possible-roles
4502	(remove-if #'(lambda(role)
4503	(when (parent role :revision revision)
4504	role))
4505	(map 'list #'role (slot-p parent-construct 'roles)))))
4506	(let ((equivalent-role
4507	(remove-if
4508	#'null
4509	(map 'list
4510	#'(lambda(role)
4511	(when
4512	(strictly-equivalent-constructs role new-role
4513	:revision revision)
4514	role))
4515	possible-roles))))
4516	(when equivalent-role
4517	(merge-constructs (first equivalent-role) new-role
4518	:revision revision)))))
4519
4520
4521	(defmethod merge-if-equivalent ((new-characteristic CharacteristicC)
4522	(parent-construct ReifiableConstructC)
4523	&key (revision TM-REVISION))
4524	(declare (integer revision) (type (or TopicC NameC) parent-construct))
4525	(let ((all-existing-characteristics
4526	(map 'list #'characteristic
4527	(cond ((typep new-characteristic 'OccurrenceC)
4528	(slot-p parent-construct 'occurrences))
4529	((typep new-characteristic 'NameC)
4530	(slot-p parent-construct 'names))
4531	((typep new-characteristic 'VariantC)
4532	(slot-p parent-construct 'variants))))))
4533	(let ((possible-characteristics ;all characteristics that are not referenced
4534	;other constructs at the given revision
4535	(remove-if #'(lambda(char)
4536	(parent char :revision revision))
4537	all-existing-characteristics)))
4538	(let ((equivalent-construct
4539	(remove-if
4540	#'null
4541	(map 'list
4542	#'(lambda(char)
4543	(when
4544	(strictly-equivalent-constructs char new-characteristic
4545	:revision revision)
4546	char))
4547	possible-characteristics))))
4548	(when equivalent-construct
4549	(merge-constructs (first equivalent-construct) new-characteristic
4550	:revision revision))))))
4551
4552
4553	(defun filter-type-instance-topics(all-topics tm &key (revision TM-REVISION))
4554	"Removes the topics tmdm:type, tmdm:instance, and tmdm:type-instance
4555	which are used for a type-instance association that is covered
4556	by the instanceOf-element in the xtm formats. So the mentioned
4557	topics only have to be exported if they are used also for other
4558	constructs as the type-instance-associations."
4559	(declare (List all-topics)
4560	(type (or Null TopicMapC) tm)
4561	(Integer revision))
4562	(let* ((type-topic
4563	(get-item-by-psi type-psi :revision revision))
4564	(instance-topic
4565	(get-item-by-psi instance-psi :revision revision))
4566	(type-instance-topic
4567	(get-item-by-psi type-instance-psi :revision revision))
4568	(topics-to-hold
4569	(remove-null
4570	(map 'list #'(lambda(top)
4571	(let ((refs
4572	(append (used-as-type top :revision revision)
4573	(used-as-theme top :revision revision)
4574	(player-in-roles top :revision revision)
4575	(list (reified-construct
4576	top :revision revision)))))
4577	(when refs
4578	(loop for ref in refs
4579	when (and (typep ref 'd::CharacteristicC)
4580	(parent ref :revision revision)
4581	(or (not tm)
4582	(find tm (in-topicmaps
4583	(parent ref :revision revision)
4584	:revision revision))))
4585	return top
4586	when (and (typep ref 'RoleC)
4587	(or
4588	(not (player ref :revision revision))
4589	(not (eql (player ref :revision revision)
4590	ref)))
4591	(parent ref :revision revision)
4592	(not (instanceOf-association-p
4593	(parent ref :revision revision)
4594	:revision revision))
4595	(or (not tm)
4596	(find tm (in-topicmaps
4597	(parent ref :revision revision)
4598	:revision revision))))
4599	return top
4600	when (and (typep ref 'd:AssociationC)
4601	(not (instanceOf-association-p
4602	ref :revision 0))
4603	(or (not tm)
4604	(find tm (in-topicmaps
4605	ref :revision revision))))
4606	return top
4607	when (and tm (typep ref 'd:TopicMapC)
4608	(eql tm ref))
4609	return top))))
4610	(remove-null (list type-topic instance-topic type-instance-topic)))))
4611	(topics-to-remove
4612	(set-difference (list type-topic instance-topic type-instance-topic)
4613	topics-to-hold)))
4614	(set-difference all-topics topics-to-remove)))
4615
4616
4617	;; fixes a bug in elephant, where sb-mop:finalize-inheritance is called too late
4618	(let ((classes
4619	(map 'list #'find-class
4620	(list 'TopicMapConstructC 'PointerC 'IdentifierC 'PersistentIdC
4621	'ItemIdentifierC 'SubjectLocatorC 'TopicIdentificationC
4622	'ReifiableConstructC 'TopicC 'TopicMapC 'AssociationC
4623	'RoleC 'CharacteristicC 'ScopableC 'TypableC 'NameC
4624	'OccurrenceC 'VariantC 'DatatypableC 'VersionedConstructC
4625	'VersionedAssociationC 'PointerAssociationC 'ItemIdAssociationC
4626	'TopicIdAssociationC 'PersistentIdAssociationC
4627	'SubjectLocatorAssociationC 'ReifierAssociationC
4628	'CharacteristicAssociationC 'OccurrenceAssociationC
4629	'NameAssociationC 'VariantAssociationC 'RoleAssociationC
4630	'ScopeAssociationC 'TypeAssociationC 'PlayerAssociationC))))
4631	(map 'list #'sb-mop:finalize-inheritance classes))

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

Context Navigation

source: branches/gdl-frontend/src/model/datamodel.lisp

Download in other formats: