Author: lgiessmann Date: Thu Apr 1 19:06:02 2010 New Revision: 257

Log: new-datamodel: added the generic "merge-constructs" --> "CharacteristicC" => "OccurrenceC" + "NameC" + "VariantC"

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 Thu Apr 1 19:06:02 2010 @@ -3231,6 +3231,42 @@ ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

+(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) + (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))))))) +

(defmethod merge-constructs ((construct-1 ReifiableConstructC) (construct-2 ReifiableConstructC) @@ -3258,14 +3294,38 @@ :revision revision)) reifier-1))) (add-reifier older-construct merged-reifier :revision revision)))) - (when (eql (type-of newer-construct) 'ReifiableConstructC) + (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)) + (mark-as-deleted newer-construct :revision revision) + (add-to-version-history older-construct :start-revision revision)) older-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)) @@ -3281,8 +3341,12 @@ (dolist (locator (locators newer-construct :revision revision)) (delete-locator newer-construct locator :revision revision) (add-locator older-construct locator :revision revision)) - ;;occurrences - ;;names + variants + (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