
Author: lgiessmann Date: Tue Nov 17 14:02:13 2009 New Revision: 143 Log: added a function to merge reifier-topics. unit-tests are currently missing. the add-refier function can be used by all importers in the "merge-topic"-functions. Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 17 14:02:13 2009 @@ -631,7 +631,7 @@ err reifier-uri)) (let ((reifier-topic (identified-construct item-identifier))) (unless (typep reifier-topic 'TopicC) - (error "~aitem-identifier ~a must be bound to a topic, but is ~a" + (error "~anitem-identifier ~a must be bound to a topic, but is ~a" err reifier-uri (type-of reifier-topic))) (cond ((and (not (reifier construct)) @@ -640,8 +640,7 @@ (setf (reified reifier-topic) construct)) ((and (not (reified reifier-topic)) (reifier construct)) - ;merge topics - t) + (merge-reifier-topics (reifier construct) reifier-topic)) ((and (not (reifier construct)) (reified reifier-topic)) (error "~a~a reifies already another object ~a" @@ -650,23 +649,50 @@ (when (not (eql (reified reifier-topic) construct)) (error "~a~a reifies already another object ~a" err reifier-uri (reified reifier-topic))) - ;merge both topics or throw an error - t))))) + (merge-reifier-topics (reifier construct) reifier-topic)))))) construct)) - (defgeneric merge-reifier-topics (old-topic new-topic) + ;;the reifier topics are not only merged but also bound to the reified-construct (:method ((old-topic TopicC) (new-topic TopicC)) - ;move all item-identifiers to the new topic ;check if they are already existing - ;move all subject-locators to the new topic ;check if they are already existing - ;move all subject-identifiers to the new topic ;check if they are already existing - ;move all names to the new topic ;check if they are already existing - ;move all occurrences to the new topic ;check if they are already existing - ;check all objects where the topic is the type of - ;check all roles where the topic is a player of - ;check all objects where the topic is a scope of - (format t "~a~a" old-topic new-topic) - )) + (unless (eql old-topic new-topic) + ;merges all identifiers + (move-identifiers old-topic new-topic) + (move-identifiers old-topic new-topic :what 'locators) + (move-identifiers old-topic new-topic :what 'psis) + (move-identifiers old-topic new-topic :what 'topic-identifiers) + ;merges all typed-object-associations + (dolist (typed-construct (used-as-type new-topic)) + (remove-association typed-construct 'instance-of new-topic) + (add-association typed-construct 'instance-of old-topic)) + ;merges all scope-object-associations + (dolist (scoped-construct (used-as-theme new-topic)) + (remove-association scoped-construct 'theme new-topic) + (add-association scoped-construct 'theme old-topic)) + (dolist (tm (in-topicmaps new-topic)) + (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it + (dolist (a-role (player-in-roles new-topic)) + (remove-association a-role 'player new-topic) + (add-association a-role 'player old-topic)) + ;merges all names + (dolist (name (names new-topic)) + (remove-association name 'topic new-topic) + (add-association name 'topic old-topic)) + ;merges all occurrences + (dolist (occurrence (occurrences new-topic)) + (remove-association occurrence 'topic new-topic) + (add-association occurrence 'topic old-topic)) + ;merges all version-infos + (let ((versions-to-move + (loop for vrs in (versions new-topic) + when (not (find-if #'(lambda(x) + (and (= (start-revision x) (start-revision vrs)) + (= (end-revision x) (end-revision vrs)))) + (versions old-topic))) + collect vrs))) + (dolist (vrs versions-to-move) + (remove-association vrs 'versioned-construct new-topic) + (add-association vrs 'versioned-construct old-topic)))))) (defgeneric item-identifiers (construct &key revision) @@ -1050,6 +1076,39 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) +(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers)) + "Moves all identifiers from the source-topic to the destination topic." + (declare (TopicC destination-topic source-topic)) + (let ((all-source-identifiers + (cond + ((eql what 'item-identifiers) + (item-identifiers source-topic)) + ((eql what 'locators) + (locators source-topic)) + (t + (psis source-topic)))) + (all-destination-identifiers + (cond + ((eql what 'item-identifiers) + (item-identifiers destination-topic)) + ((eql what 'locators) + (locators destination-topic)) + ((eql what 'psis) + (psis destination-topic)) + ((eql what 'topic-identifiers) + (topic-identifiers destination-topic))))) + (let ((identifiers-to-move + (loop for id in all-source-identifiers + when (not (find-if #'(lambda(x) + (if (eql what 'topic-identifiers) + (string= (xtm-id x) (xtm-id id)) + (string= (uri x) (uri id)))) + all-destination-identifiers)) + collect id))) + (dolist (item identifiers-to-move) + (remove-association source-topic what item) + (add-association destination-topic what item))))) + (defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis))