source: trunk/src/model/datamodel.lisp

Last change on this file was 754, checked in by lgiessmann, 14 years ago

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