Author: lgiessmann Date: Tue Apr 6 16:09:58 2010 New Revision: 267
Log: new-datamodel: added "merge-constructs" --> "RoleC"
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 Tue Apr 6 16:09:58 2010 @@ -155,6 +155,10 @@ (in-package :datamodel)
+;;TODO: call delete-construct for all child-constructs that are: +;; *exist-in-revision-history => nil +;; *are not referenced by other constructs +;; --> iis, psis, sls, tids, names, occs, variants, roles ;;TODO: mark-as-deleted should call mark-as-deleted for every owned ;; versioned-construct of the called construct ;;TODO: add: add-to-version-history (parent) to all @@ -3636,20 +3640,40 @@ (delete-construct newer-assoc)) older-assoc))))
-;TODO: merge-constructs: RoleC (merge parents), AssociationC
- - - - - -;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) +(defmethod merge-constructs ((construct-1 RoleC) (construct-2 RoleC) &key (revision *TM-REVISION*)) - (or revision) - (if construct-1 construct-1 construct-2)) - - - - -;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (declare (integer *TM-REVISION*)) + (if (eql construct-1 construct-2) + construct-1 + (let ((older-role (find-oldest-construct construct-1 construct-2))) + (let ((newer-role (if (eql older-role construct-1) + construct-2 + construct-1))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (let ((parent-1 (parent older-role :revision revision)) + (parent-2 (parent newer-role :revision revision))) + (cond ((and parent-1 (eql parent-1 parent-2)) + (move-referenced-constructs newer-role older-role + :revision revision) + (delete-role newer-role parent-2 :revision revision) + (add-role older-role parent-1 :revision revision)) + ((and parent-1 parent-2) + (let ((active-assoc (merge-constructs parent-1 parent-2 + :revision revision))) + (if (find older-role (roles active-assoc + :revision revision)) + older-role + newer-role))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-role newer-role)) + (src (if parent-1 newer-role older-role))) + (move-referenced-constructs src dst :revision revision) + dst)) + (t + (move-referenced-constructs newer-role older-role + :revision revision) + older-role))))))) \ No newline at end of file