Author: lgiessmann Date: Tue Apr 6 11:44:47 2010 New Revision: 263
Log: new-datamodel: replaced "merge-cosntructs" --> "NameC", "OccurrenceC", "VariantC" by a generic for "CharacteristicC"; added the generics "add-characteristic" and "delete-characteristic" for "NameC", "VariantC", "OccurrenceC"
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 11:44:47 2010 @@ -758,6 +758,18 @@
;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric add-characteristic (construct characteristic &key revision) + (:documentation "Adds the passed characterisitc to the given topic by calling + add-name or add-occurrences. + Variants are added to names by calling add-name.")) + + +(defgeneric delete-characteristic (construct characteristic &key revision) + (:documentation "Deletes the passed characteristic oif the given topic by + calling delete-name or delete-occurrence. + Variants are deleted from names by calling delete-variant.")) + + (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")) @@ -832,7 +844,6 @@ The latest construct is either the one with end-revision=0 or with the highest end-revision value."))
- (defgeneric owned-p (construct) (:documentation "Returns t if the passed construct is referenced by a parent TM construct.")) @@ -1638,6 +1649,24 @@ construct)))
+(defmethod add-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (add-name construct characteristic :revision revision) + (add-occurrence construct characteristic :revision revision))) + + +(defmethod delete-characteristic ((construct TopicC) + (characteristic CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or NameC OccurrenceC) characteristic)) + (if (typep characteristic 'NameC) + (delete-name construct characteristic :revision revision) + (delete-occurrence construct characteristic :revision revision))) + + (defgeneric player-in-roles (construct &key revision) (:documentation "Returns the RoleC-objects that correspond with the passed construct and the passed version.") @@ -2156,6 +2185,18 @@ construct)))
+(defmethod add-characteristic ((construct NameC) (characteristic VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (add-variant construct characteristic :revision revision)) + + +(defmethod delete-characteristic ((construct NameC) (characteristic VariantC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (delete-variant construct characteristic :revision revision)) + + ;;; AssociationC (defmethod equivalent-constructs ((construct-1 AssociationC) (construct-2 AssociationC) @@ -3287,33 +3328,48 @@ (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)))) + (declare (integer revision)) + (remove-if + #'null + (append + (move-identifiers source destination :revision 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 NameC) (destination NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (append (call-next-method) + (move-variants source destination :revision revision)))
(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))) + (typables (used-as-type source :revision revision)) + (ids (move-identifiers source destination :revision revision))) (dolist (role roles) (delete-player role source :revision revision) (add-player role destination :revision revision)) @@ -3323,7 +3379,7 @@ (dolist (typable typables) (delete-type typable source :revision revision) (add-type typable destination :revision revision)) - (append roles scopables typables))) + (remove-if #'null (append roles scopables typables ids))))
(defgeneric move-reified-construct (source destination &key revision) @@ -3373,7 +3429,6 @@ (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)))) @@ -3399,7 +3454,6 @@ (if equivalent-var (progn (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)))) @@ -3423,10 +3477,8 @@ destination-name)) (names destination :revision revision)))) (if equivalent-name - (progn - (move-variants name equivalent-name :revision revision) + (progn (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)))) @@ -3467,7 +3519,6 @@ (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) @@ -3481,52 +3532,77 @@ older-topic))))
-(defmethod merge-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) +(defmethod merge-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) &key (revision *TM-REVISION*)) + (declare (integer revision)) (if (eql construct-1 construct-2) construct-1 - (progn - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) - (error "From merge-constructs(): ~a is not mergable with ~a" - construct-1 construct-2)) - (let ((parent-1 (parent construct-1 :revision revision)) - (parent-2 (parent construct-2 :revision revision))) - (when (not (and parent-1 parent-2)) - (error "From merge-constructs():~a and ~a must be associated with a topic" - construct-1 construct-2)) - (if (and parent-1 (eql parent-1 parent-2)) - (let ((older-occ (find-oldest-construct construct-1 construct-2))) - (let ((newer-occ (if (eql older-occ construct-1) - construct-2 - construct-1))) - (move-identifiers newer-occ older-occ :revision revision) - (move-referenced-constructs newer-occ older-occ - :revision revision) - (delete-occurrence parent-1 construct-1 :revision revision) - (add-occurrence parent-1 construct-2 :revision revision) - older-occ)) - (let ((active-topic - (merge-constructs parent-1 parent-2 :revision revision))) - (if (find construct-1 - (occurrences active-topic :revision revision)) - construct-1 - construct-2))))))) + (let ((older-char (find-oldest-construct construct-1 construct-2))) + (let ((newer-char (if (eql older-char construct-1) + construct-2 + construct-1))) + (let ((parent-1 (parent older-char :revision revision)) + (parent-2 (parent newer-char :revision revision))) + (unless (strictly-equivalent-constructs construct-1 construct-2 + :revision revision) + (error "From merge-constructs(): ~a and ~a are not mergable" + construct-1 construct-2)) + (cond ((and parent-1 (eql parent-1 parent-2)) + (move-referenced-constructs newer-char older-char + :revision revision) + (delete-characteristic newer-char parent-2 + :revision revision) + older-char) + ((and parent-1 parent-2) + (let ((active-parent (merge-constructs parent-1 parent-2 + :revision revision))) + (let ((found-older-char + (cond ((typep older-char 'OccurrenceC) + (find older-char + (occurrences + active-parent :revision revision))) + ((typep older-char 'NameC) + (find older-char + (names + active-parent :revision revision))) + ((typep older-char 'VariantC) + (find-if + #'(lambda(name) + (find older-char + (variants name + :revision revision))) + (names active-parent :revision revision)))))) + (if found-older-char + older-char + newer-char)))) + ((or parent-1 parent-2) + (let ((dst (if parent-1 older-char newer-char)) + (src (if parent-1 newer-char older-char))) + (move-referenced-constructs src dst :revision revision) + dst)) + (t + (move-referenced-constructs newer-char older-char + :revision revision) + older-char))))))) +
-;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
+;TODO: merge-constructs: RoleC (merge parents and return the active role object), +;; AssociationC, TopicMapC, + + + + ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod merge-constructs ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) &key (revision *TM-REVISION*)) @@ -3539,80 +3615,7 @@ ;;; end hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defmethod merge-constructs ((construct-1 VariantC) (construct-2 VariantC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-var (find-oldest-construct construct-1 construct-2))) - (let ((newer-var (if (eql older-var construct-1) - construct-2 - construct-1))) - (let ((parent-1 (parent older-var :revision revision)) - (parent-2 (parent newer-var :revision revision))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) - (cond ((and parent-1 parent-2) - (let ((active-parent - (merge-constructs parent-1 parent-2 - :revision revision))) - (let ((all-names (names active-parent :revision revision))) - (if (find-if #'(lambda(name) - (find older-var (variants name :revision - revision))) - all-names) - older-var - newer-var)))) - ((or parent-1 parent-2) - (let ((dst (if parent-1 older-var newer-var)) - (src (if parent-1 newer-var older-var))) - (move-identifiers src dst :revision revision) - (move-referenced-constructs src dst :revision revision) - dst)) - (t - (move-identifiers newer-var older-var :revision revision) - (move-referenced-constructs newer-var older-var - :revision revision) - older-var))))))) -
-(defmethod merge-constructs ((construct-1 NameC) (construct-2 NameC) - &key (revision *TM-REVISION*)) - (declare (integer revision)) - (if (eql construct-1 construct-2) - construct-1 - (let ((older-name (find-oldest-construct construct-1 construct-2))) - (let ((newer-name (if (eql older-name construct-1) - construct-2 - construct-1))) - (let ((parent-1 (parent older-name :revision revision)) - (parent-2 (parent newer-name :revision revision))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) - (error "From merge-constructs(): ~a and ~a are not mergable" - construct-1 construct-2)) - (cond ((and parent-1 parent-2) - (let ((active-parent (merge-constructs parent-1 parent-2 - :revision revision))) - (if (find older-name (names active-parent - :revision revision)) - older-name - newer-name))) - ((or parent-1 parent-2) - (let ((dst (if parent-1 older-name newer-name)) - (src (if parent-1 newer-name older-name))) - (move-identifiers src dst :revision revision) - (move-referenced-constructs src dst :revision revision) - (move-variants src dst :revision revision) - dst)) - (t - (move-identifiers newer-name older-name :revision revision) - (move-referenced-constructs newer-name older-name - :revision revision) - (move-variants newer-name older-name :revision revision) - older-name)))))))
;TODO: --> include move-yx in move-referenced-constructs \ No newline at end of file