Author: lgiessmann Date: Mon Apr 12 11:06:19 2010 New Revision: 274

Log: new-datamodel: added merging of characteristics when added with "add-<type>"

Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.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 12 11:06:19 2010 @@ -157,12 +157,9 @@

-;;TODO: modify 2x add-parent --> use add-characteristic and add-role -;;TODO: call merge-if-equivalent in 2x add-parent ;;TODO: mark-as-deleted should call mark-as-deleted for every owned ??? ;; versioned-construct of the called construct, same for add-xy ??? ;; and associations of player -;;TODO: check for duplicate identifiers after topic-creation/merge ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -842,6 +839,12 @@

;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric find-self-or-equal (construct parent-construct &key revision) + (:documentation "Returns the construct 'construct' if is owned by the + parent-construct or an equal construct or nil if there + is no equal one.")) + + (defgeneric merge-if-equivalent (new-characteristic parent-construct &key revision) (:documentation "Merges the new characteristic/role with one equivalent of the @@ -1692,10 +1695,11 @@ (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) - (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) - construct) - return name-assoc))) + (let ((name-assoc + (loop for name-assoc in (slot-p construct 'names) + when (eql (parent-construct name-assoc) + construct) + return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) (make-construct 'NameAssociationC :parent-construct construct @@ -1752,9 +1756,10 @@ (let ((all-occurrences (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) - (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) construct) - return occ-assoc))) + (let ((occ-assoc + (loop for occ-assoc in (slot-p construct 'occurrences) + when (eql (parent-construct occ-assoc) construct) + return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) (make-construct 'OccurrenceAssociationC :parent-construct construct @@ -2017,6 +2022,27 @@

;;; CharacteristicC +(defmethod find-self-or-equal ((construct CharacteristicC) + (parent-construct TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or OccurrenceC NameC) construct)) + (let ((chars (if (typep construct 'OccurrenceC) + (occurrences parent-construct :revision revision) + (names parent-construct :revision revision)))) + (let ((self (find construct chars))) + (if self + self + (let ((equal-char + (remove-if #'null + (map 'list + #'(lambda(char) + (strictly-equivalent-constructs + char construct :revision revision)) + chars)))) + (when equal-char + (first equal-char))))))) + + (defmethod delete-if-not-referenced ((construct CharacteristicC)) (let ((references (slot-p construct 'parent))) (when (or (not references) @@ -2130,6 +2156,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (declare (integer revision)) (let ((already-set-parent (parent construct :revision revision)) (same-parent-assoc ;should contain an object that was marked as deleted (loop for parent-assoc in (slot-p construct 'parent) @@ -2143,29 +2170,36 @@ :referenced-construct construct :existing-reference (parent construct :revision revision) :new-reference parent-construct))) - (cond (already-set-parent - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (let ((association-type (cond ((typep construct 'OccurrenceC) - 'OccurrenceAssociationC) - ((typep construct 'NameC) - 'NameAssociationC) - (t - 'VariantAssociationC)))) - (make-construct association-type - :characteristic construct - :parent-construct parent-construct - :start-revision revision))))) - (when (typep parent-construct 'VersionedConstructC) - (add-to-version-history parent-construct :start-revision revision)) - construct) + (let ((merged-char + (merge-if-equivalent construct parent-construct :revision revision))) + (if merged-char + merged-char + (progn + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc + :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc + :start-revision revision)) + (t + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision)))) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct)))))

(defmethod delete-parent ((construct CharacteristicC) @@ -2215,6 +2249,24 @@

;;; VariantC +(defmethod find-self-or-equal ((construct VariantC) (parent-construct NameC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((vars (variants parent-construct :revision revision))) + (let ((self (find construct vars))) + (if self + self + (let ((equal-var + (remove-if #'null + (map 'list + #'(lambda(var) + (strictly-equivalent-constructs + var construct :revision revision)) + vars)))) + (when equal-var + (first equal-var))))))) + + (defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC) &key (revision *TM-REVISION*)) (declare (ignorable revision)) @@ -2475,6 +2527,24 @@

;;; RoleC +(defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((p-roles (roles parent-construct :revision revision))) + (let ((self (find construct p-roles))) + (if self + self + (let ((equal-role + (remove-if #'null + (map 'list + #'(lambda(role) + (strictly-equivalent-constructs + role construct :revision revision)) + p-roles)))) + (when equal-role + (first equal-role))))))) + + (defmethod delete-if-not-referenced ((construct RoleC)) (let ((references (slot-p construct 'parent))) (when (or (not references) @@ -2586,6 +2656,7 @@

(defmethod add-parent ((construct RoleC) (parent-construct AssociationC) &key (revision *TM-REVISION*)) + (declare (integer revision)) (let ((already-set-parent (parent construct :revision revision)) (same-parent-assoc (loop for parent-assoc in (slot-p construct 'parent) when (eql parent-construct (parent-construct parent-assoc)) @@ -2598,22 +2669,29 @@ :referenced-construct construct :existing-reference (parent construct :revision revision) :new-reference parent-construct))) - (cond (already-set-parent - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (make-construct 'RoleAssociationC - :role construct - :parent-construct parent-construct - :start-revision revision)))) - (add-to-version-history parent-construct :start-revision revision) - construct) + (let ((merged-role + (merge-if-equivalent construct parent-construct :revision revision))) + (if merged-role + merged-role + (progn + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc + :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc + :start-revision revision)) + (t + (make-construct 'RoleAssociationC + :role construct + :parent-construct parent-construct + :start-revision revision))) + (add-to-version-history parent-construct :start-revision revision) + construct)))))

(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC) @@ -3287,12 +3365,16 @@ :instance-of instance-of) existing-role)) (map 'list #'role (slot-p parent 'roles))))))) - (cond ((> (length existing-roles) 1) - (merge-all-constructs existing-roles)) - (existing-roles - (first existing-roles)) - (t - (make-instance 'RoleC)))))) + (if (and existing-roles + (or (eql parent (parent (first existing-roles) + :revision start-revision)) + (not (parent (first existing-roles) + :revision start-revision)))) + (progn + (add-role parent (first existing-roles) + :revision start-revision) + (first existing-roles)) + (make-instance 'RoleC))))) (when player (add-player role player :revision start-revision)) (when parent @@ -3412,7 +3494,7 @@ :argument-symbol 'start-revision :function-symbol 'make-characgteristic))) (let ((characteristic - (let ((existing-characteristic + (let ((existing-characteristics (when parent (remove-if #'null @@ -3425,8 +3507,15 @@ :instance-of instance-of) existing-characteristic)) (get-all-characteristics parent class-symbol)))))) - (if existing-characteristic - (first existing-characteristic) + (if (and existing-characteristics + (or (eql parent (parent (first existing-characteristics) + :revision start-revision)) + (not (parent (first existing-characteristics) + :revision start-revision)))) + (progn + (add-characteristic parent (first existing-characteristics) + :revision start-revision) + (first existing-characteristics)) (make-instance class-symbol :charvalue charvalue :datatype datatype))))) (when (typep characteristic 'NameC)

Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Mon Apr 12 11:06:19 2010 @@ -80,7 +80,8 @@ :test-make-TopicC :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC - :test-move-referenced-constructs-NameC)) + :test-move-referenced-constructs-NameC + :test-move-referenced-constructs-TopicC))

;;TODO: test merge-constructs @@ -2931,6 +2932,57 @@ (variants name-2 :revision rev-2)))))))))

+(test test-move-referenced-constructs-TopicC () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200)) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (tid-1 (make-construct 'TopicIdentificationC :uri "tid-1" + :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC :uri "tid-2" + :xtm-id "xtm-2")) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-2" + :themes (list theme-2))) + (variant-3 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "var-1" + :themes (list theme-1))) + (occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1))) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-2" + :instance-of type-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :charvalue "occ-1" + :instance-of type-1 + :themes (list theme-1)))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1)) + ) + ))))))

(defun run-datamodel-tests() @@ -2991,4 +3043,5 @@ (it.bese.fiveam:run! 'test-find-oldest-construct) (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) + (it.bese.fiveam:run! 'test-move-referenced-constructs-TopicC) ) \ No newline at end of file