Author: lgiessmann Date: Mon Apr 5 14:07:59 2010 New Revision: 258

Log: new-datamodel: added the generics "add-reified-construct" and "delet-reified-construct" for "TopicC"; added "merge-constructs" for "TopicC"; changed the behaviour of merging "CharacteristicC"s

Modified: branches/new-datamodel/src/model/datamodel.lisp

Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Apr 5 14:07:59 2010 @@ -155,6 +155,8 @@ (in-package :datamodel)

+;;TODO: mark-as-deleted should call mark as deleted for every owned +;; versioned-construct of the called construct ;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: add: add-to-version-history (parent) to all ;; "add-<construct>"/"delete-<construct>" generics @@ -167,9 +169,7 @@ ;; and a merge should be done ;;TODO: use some exceptions --> more than one type, ;; identifier, not-mergable merges, missing-init-args... -;;TODO: implement merge-construct -> ReifiableConstructC -> ... -;; the method should merge two constructs that are inherited from -;; ReifiableConstructC +

;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -758,6 +758,11 @@

;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric mark-as-deleted (construct &key source-locator revision) + (:documentation "Mark a construct as deleted if it comes from the source + indicated by source-locator")) + + (defgeneric find-oldest-construct (construct-1 construct-2) (:documentation "Returns the construct which owns the oldes version info. If a construct is not a versioned construct the oldest @@ -855,6 +860,17 @@

;;; VersionedConstructC +(defgeneric does-not-exist-in-revision-history (versioned-construct) + (:documentation "Returns t if the passed construct does not exist in any + revision, i.e. the construct has no version-infos or exactly + one whose start-revision is equal to its end-revision.") + (:method ((versioned-construct VersionedConstructC)) + (or (not (versions versioned-construct)) + (and (= (length (versions versioned-construct)) 1) + (= (start-revision (first (versions versioned-construct))) + (end-revision (first (versions versioned-construct)))))))) + + (defmethod find-oldest-construct ((construct-1 VersionedConstructC) (construct-2 VersionedConstructC)) (let ((vi-1 (find-version-info (list construct-1))) @@ -963,16 +979,14 @@ t)))

-(defgeneric mark-as-deleted (construct &key source-locator revision) - (:documentation "Mark a construct as deleted if it comes from the source - indicated by source-locator") - (:method ((construct VersionedConstructC) &key source-locator revision) - (declare (ignorable source-locator)) - (let - ((last-version ;the last active version - (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision))))) +(defmethod marks-as-deleted ((construct VersionedConstructC) + &key source-locator revision) + (declare (ignorable source-locator)) + (let + ((last-version ;the last active version + (find 0 (versions construct) :key #'end-revision))) + (when last-version + (setf (end-revision last-version) revision))))

;;; TopicMapconstructC @@ -1661,6 +1675,24 @@ (reifiable-construct (first assocs))))))

+(defgeneric add-reified-construct (construct reified-construct &key revision) + (:documentation "Sets the passed construct as reified-consturct of the given + topic.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (add-reifier reified-construct construct :revision revision))) + + +(defgeneric delete-reified-construct (construct reified-construct &key revision) + (:documentation "Unsets the passed construct as reified-construct of the + given topic.") + (:method ((construct TopicC) (reified-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (delete-reifier reified-construct construct :revision revision))) + + (defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))

@@ -1931,7 +1963,7 @@ (parent-construct ReifiableConstructC) &key (revision *TM-REVISION*)) (let ((already-set-parent (parent construct :revision revision)) - (same-parent-assoc ;should contain a object that was marked as deleted + (same-parent-assoc ;should contain an object that was marked as deleted (loop for parent-assoc in (slot-p construct 'parent) when (eql parent-construct (parent-construct parent-assoc)) return parent-assoc))) @@ -2598,13 +2630,14 @@ (merge-constructs (reifier construct :revision revision) reifier-topic) reifier-topic))) - (let ((all-constructs - (let ((inner-construct (reified-construct merged-reifier-topic - :revision revision))) - (when inner-construct - (list inner-construct))))) + (let ((all-constructs (map 'list #'reifiable-construct + (slot-p reifier-topic 'reified-construct)))) (let ((merged-construct construct)) - (cond ((find construct all-constructs) + (cond ((reified-construct merged-reifier-topic :revision revision) + (merge-constructs + (reified-construct merged-reifier-topic :revision revision) + construct)) + ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in (slot-p merged-reifier-topic 'reified-construct) @@ -2613,8 +2646,6 @@ return reifier-assoc))) (add-to-version-history reifier-assoc :start-revision revision))) - (all-constructs - (merge-constructs (first all-constructs) construct)) (t (make-construct 'ReifierAssociationC :reifiable-construct construct @@ -2959,7 +2990,7 @@ (not start-revision)) (error "From make-association(): start-revision must be set")) (let ((association - (let ((existing-association + (let ((existing-associations (remove-if #'null (map 'list #'(lambda(existing-association) @@ -2970,9 +3001,12 @@ :instance-of instance-of) existing-association)) (elephant:get-instances-by-class 'AssociationC))))) - (if existing-association - (first existing-association) - (make-instance 'AssociationC))))) + (cond ((> (length existing-associations) 1) + (merge-all-constructs existing-associations)) + (existing-associations + (first existing-associations)) + (t + (make-instance 'AssociationC)))))) (dolist (role-plist roles) (add-role association (apply #'make-construct 'RoleC @@ -2993,7 +3027,7 @@ (not start-revision)) (error "From make-role(): start-revision must be set")) (let ((role - (let ((existing-role + (let ((existing-roles (when parent (remove-if #'null @@ -3005,9 +3039,12 @@ :instance-of instance-of) existing-role)) (map 'list #'role (slot-p parent 'roles))))))) - (if existing-role - (first existing-role) - (make-instance 'RoleC))))) + (cond ((> (length existing-roles) 1) + (merge-all-constructs existing-roles)) + (existing-roles + (first existing-roles)) + (t + (make-instance 'RoleC)))))) (when player (add-player role player :revision start-revision)) (when parent @@ -3038,7 +3075,7 @@ :reifier reifier) existing-tm)) (elephant:get-instances-by-class 'TopicMapC))))) - (cond ((and existing-tms (> (length existing-tms) 1)) + (cond ((> (length existing-tms) 1) (merge-all-constructs existing-tms)) (existing-tms (first existing-tms)) @@ -3077,7 +3114,7 @@ :topic-identifiers topic-identifiers) existing-topic)) (elephant:get-instances-by-class 'TopicC))))) - (cond ((and existing-topics (> (length existing-topics) 1)) + (cond ((> (length existing-topics) 1) (merge-all-constructs existing-topics)) (existing-topics (first existing-topics)) @@ -3205,167 +3242,265 @@

- - - - - - - - - - - - - - +;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric move-identifiers (source destination &key revision) + (:documentation "Sets all identifiers as mark as deleted in the given + version and adds the marked identifiers to the + destination construct."))

+(defmethod move-identifiers ((source ReifiableConstructC) + (destination ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((iis (item-identifiers source :revision revision))) + (dolist (ii iis) + (delete-item-identifier source ii :revision revision) + (add-item-identifier destination ii :revision revision)) + iis))

-;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) +(defmethod move-identifiers ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) - (or revision) - (if construct-1 construct-1 construct-2)) -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (declare (integer revision)) + (let ((iis (call-next-method)) + (tids (topic-identifiers source :revision revision)) + (psis (psis source :revision revision)) + (sls (locators source :revision revision))) + (dolist (tid tids) + (delete-topic-identifier source tid :revision revision) + (add-topic-identifier destination tid :revision revision)) + (dolist (psi psis) + (delete-psi source psi :revision revision) + (add-psi destination psi :revision revision)) + (dolist (sl sls) + (delete-locator source sl :revision revision) + (add-locator destination sl :revision revision)) + (append tids iis psis sls))) + + +(defgeneric move-referenced-constructs (source destination &key revision) + (:documentation "Moves all referenced constructs in the given version from + the source TM-construct to the destination TM-construct.")) + + +(defmethod move-referenced-constructs ((source ReifiableConstructC) + (destination ReifiableConstructC) + &key (revision *TM-REVISION*)) + (let ((source-reifier (reifier source :revision revision)) + (destination-reifier (reifier destination :revision revision))) + (cond ((and source-reifier destination-reifier) + (delete-reifier (reified-construct source-reifier :revision revision) + source-reifier :revision revision) + (delete-reifier (reified-construct destination-reifier + :revision revision) + destination-reifier :revision revision) + (let ((merged-reifier + (merge-constructs source-reifier destination-reifier + :revision revision))) + (add-reifier destination merged-reifier :revision revision))) + (source-reifier + (delete-reifier (reified-construct source-reifier :revision revision) + source-reifier :revision revision) + (add-reifier destination source-reifier :revision revision) + source-reifier) + (destination-reifier + (add-reifier destination destination-reifier :revision revision) + destination-reifier)))) + + +(defmethod move-referenced-constructs ((source TopicC) (destination TopicC) + &key (revision *TM-REVISION*)) + (let ((roles (player-in-roles source :revision revision)) + (scopables (used-as-theme source :revision revision)) + (typables (used-as-type source :revision revision))) + (dolist (role roles) + (delete-player role source :revision revision) + (add-player role destination :revision revision)) + (dolist (scopable scopables) + (delete-theme scopable source :revision revision) + (add-theme scopable destination :revision revision)) + (dolist (typable typables) + (delete-type typable source :revision revision) + (add-type typable destination :revision revision)) + (append roles scopables typables))) + + +(defgeneric move-reified-construct (source destination &key revision) + (:documentation "Moves the refied TM-construct from the source topic + to the given destination topic.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((source-reified (reified-construct source :revision revision)) + (destination-reified (reified-construct destination + :revision revision))) + (unless (eql (type-of source-reified) (type-of destination-reified)) + (error "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" + source destination source-reified destination-reified)) + (cond ((and source-reified destination-reified) + (delete-reifier source-reified source :revision revision) + (delete-reifier destination-reified destination :revision revision) + (let ((merged-reified + (merge-constructs source-reified destination-reified + :revision revision))) + (add-reifier merged-reified destination :revision revision) + merged-reified)) + (source-reified + (delete-reifier source source-reified :revision revision) + (add-reifier destination source-reified :revision revision) + source-reified) + (destination-reified + (add-reifier destination destination-reified :revision revision) + destination-reified))))) + + +(defgeneric move-occurrences (source destination &key revision) + (:documentation "Moves all occurrences from the source topic to the + destination topic. If occurrences are TMDM equal + they are merged, i.e. one is marked-as-deleted.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((occs-to-move (occurrences source :revision revision))) + (dolist (occ occs-to-move) + (delete-occurrence occ source :revision revision) + (let ((equivalent-occ + (find-if #'(lambda (destination-occ) + (when + (strictly-equivalent-constructs + occ destination-occ :revision revision) + destination-occ)) + (occurrences destination :revision revision)))) + (if equivalent-occ + (progn + (add-occurrence destination equivalent-occ :revision revision) + (move-identifiers occ equivalent-occ :revision revision) + (move-referenced-constructs occ equivalent-occ + :revision revision)) + (add-occurrence destination occ :revision revision)))) + occs-to-move)))

-(defun merge-characteristics (older-parent newer-parent - &key (revision *TM-REVISION*) - (characteristic-type 'OccurrenceC)) - "Deletes all characteristics of the given type from the newer-parent. - Merges equivalent characteristics between the newer and the older parent. - Adds all characteristics from the newer-parent to the older-parent or adds - the merged characterisitcs to the older-parent." - (declare (type (or TopicC NameC) older-parent newer-parent) - (integer revision) (symbol characteristic-type)) - (let ((object-name - (subseq (write-to-string characteristic-type) 0 - (- (length (write-to-string characteristic-type)) 1)))) - (let ((request-fun - (symbol-function - (find-symbol (concatenate 'string object-name "S")))) - (delete-fun - (symbol-function - (find-symbol (concatenate 'string "DELETE-" object-name)))) - (add-fun - (symbol-function - (find-symbol (concatenate 'string "ADD-" object-name))))) - (dolist (newer-char (funcall request-fun newer-parent :revision revision)) - (let ((older-char - (find-if #'(lambda(char) - (equivalent-constructs char newer-char - :revision revision)) - (funcall request-fun older-parent :revision revision)))) - (funcall delete-fun newer-parent newer-char :revision revision) - (if (and newer-char older-char) +(defgeneric move-variants (source destination &key revision) + (:documentation "Moves all variants from the source name to the destination + name. If any variants are TMDM equal they are merged --> + i.e. one of the variants is marked-as-deleted.") + (:method ((source NameC) (destination NameC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((vars-to-move (variants source :revision revision))) + (dolist (var vars-to-move) + (delete-variant source var :revision revision) + (let ((equivalent-var + (find-if #'(lambda (destination-var) + (when + (strictly-equivalent-constructs + var destination-var :revision revision) + destination-var)) + (variants destination :revision revision)))) + (if equivalent-var (progn - (funcall delete-fun older-parent older-char :revision revision) - (funcall add-fun older-parent - (merge-constructs newer-char older-char - :revision revision))) - (funcall add-fun older-parent newer-char))))))) + (add-variant destination equivalent-var :revision revision) + (move-identifiers var equivalent-var :revision revision) + (move-referenced-constructs var equivalent-var + :revision revision)) + (add-variant destination var :revision revision)))) + vars-to-move)))

-(defmethod merge-constructs ((construct-1 ReifiableConstructC) - (construct-2 ReifiableConstructC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-construct (find-oldest-construct construct-1 construct-2))) - (let ((newer-construct (if (eql older-construct construct-1) - construct-2 - construct-1))) - (dolist (ii (item-identifiers newer-construct :revision revision)) - (delete-item-identifier newer-construct ii :revision revision) - (add-item-identifier older-construct ii :revision revision)) - (let ((reifier-1 (reifier newer-construct :revision revision)) - (reifier-2 (reifier older-construct :revision revision))) - (when reifier-1 - (delete-reifier newer-construct reifier-1 :revision revision) - (let ((merged-reifier - (if reifier-2 - (progn - (delete-reifier older-construct reifier-2 - :revision revision) - (merge-constructs reifier-1 reifier-2 - :revision revision)) - reifier-1))) - (add-reifier older-construct merged-reifier :revision revision)))) - (when (and (eql (type-of newer-construct) 'ReifiableConstructC) - (eql (type-of newer-construct) 'ReifiableConstructC) - (typep newer-construct 'VersionedConstructC) - (typep older-construct 'VersionedConstructC)) - ;;If the older-construct is a "real" ReifiableConstructC and no sub - ;;class the older-construct must be marked as deleted. - ;;Sub classes are marked as deleted in the "next-method" calls. - (mark-as-deleted newer-construct :revision revision) - (add-to-version-history older-construct :start-revision revision)) - older-construct)))) - +(defgeneric move-names (source destination &key revision) + (:documentation "Moves all names from the source topic to the destination + topic. If any names are equal they are merged, i.e. + one of the names is marked-as-deleted.") + (:method ((source TopicC) (destination TopicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((names-to-move (names source :revision revision))) + (dolist (name names-to-move) + (delete-name source name :revision revision) + (let ((equivalent-name + (find-if #'(lambda (destination-name) + (when + (strictly-equivalent-constructs + name destination-name :revision revision) + destination-name)) + (names destination :revision revision)))) + (if equivalent-name + (progn + (move-variants name equivalent-name :revision revision) + (add-name destination equivalent-name :revision revision) + (move-identifiers name equivalent-name :revision revision) + (move-referenced-constructs name equivalent-name + :revision revision)) + (add-name destination name :revision revision)))) + names-to-move))) + + +(defun merge-changed-constructs (older-topic &key (revision *TM-REVISION*)) + (declare (TopicC older-topic)) + (dolist (construct (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision) + (player-in-roles older-topic :revision revision))) + (let ((parent (when (or (typep construct 'RoleC) + (typep construct 'CharacteristicC)) + (parent construct :revision revision)))) + (let ((found-equivalent + (find-if #'(lambda(other-construct) + (strictly-equivalent-constructs + other-construct construct :revision revision)) + (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision)) + ((typep construct 'AssociationC) + (elephant:get-instances-by-class 'AssociationC)))))) + (when found-equivalent + (merge-all-constructs (append found-equivalent (list construct))))))))

-(defmethod merge-constructs ((construct-1 CharacteristicC) - (construct-2 CharacteristicC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (unless (equivalent-constructs construct-1 construct-2 :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-construct (call-next-method))) - (let ((newer-construct (if (eql older-construct construct-1) - construct-2 - construct-1))) - (when (and (typep construct-1 'NameC) (typep construct-2 'NameC)) - (merge-characteristics older-construct newer-construct - :revision revision - :characteristic-type 'VariantC))) - older-construct)))

(defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-construct (call-next-method))) - (let ((newer-construct (if (eql older-construct construct-1) - construct-2 - construct-1))) - (dolist (psi (psis newer-construct :revision revision)) - (delete-psi newer-construct psi :revision revision) - (add-psi older-construct psi :revision revision)) - (dolist (locator (locators newer-construct :revision revision)) - (delete-locator newer-construct locator :revision revision) - (add-locator older-construct locator :revision revision)) - (merge-characteristics older-construct newer-construct - :revision revision - :characteristic-type 'OccurrenceC) - (merge-characteristics older-construct newer-construct - :revision revision - :characteristic-type 'NameC) - ;;player-in-roles - ;;used-as-type - ;;used-as-scope - ;;reified-construct - ;;in-topicmaps - )))) + (let ((older-topic (find-oldest-construct construct-1 construct-2))) + (let ((newer-topic (if (eql older-topic construct-1) + construct-2 + construct-1))) + (move-identifiers newer-topic older-topic :revision revision) + (dolist (tm (in-topicmaps newer-topic :revision revision)) + (add-to-tm tm older-topic)) + (move-names newer-topic older-topic :revision revision) + (move-occurrences newer-topic older-topic :revision revision) + (move-referenced-constructs newer-topic older-topic :revision revision) + (move-reified-construct newer-topic older-topic :revision revision) + (merge-changed-constructs older-topic :revision revision) + (mark-as-deleted newer-topic :revision revision) + (when (does-not-exist-in-revision-history newer-topic) + (delete-construct newer-topic)) + older-topic))) +

+;TODO: merge-constructs: RoleC, AssociationC, TopicMapC, +; OccurrenceC, NameC, VariantC --> call merge-constructs of the parent +; and return the active construct on what merge-constructs was initialy +; called

+;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) + &key (revision *TM-REVISION*)) + (or revision) + (if construct-1 construct-1 construct-2))

- \ No newline at end of file +;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file