Author: lgiessmann Date: Fri Apr 9 11:36:02 2010 New Revision: 271 Log: new-datamodel: added some unit-tests; fixed bugs in "add-name", "add-occurrence", "add-role" and "find-oldest-construct" 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 Fri Apr 9 11:36:02 2010 @@ -157,16 +157,18 @@ +;;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), ;; add-psi, add-locator (--> duplicate-identifier-error) -;;TODO: implement a macro "with-merge-construct" that merges constructs -;; after some data-operations are completed (should be passed as body) -;; and a merge should be done +;;TODO: implement a macro with-merge-constructs, that merges constructs +;; after all operations in the body were called @@ -840,6 +842,19 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric merge-if-equivalent (new-characteristic parent-construct + &key revision) + (:documentation "Merges the new characteristic/role with one equivalent of the + parent's charateristics/roles instead of adding the entire new + characteristic/role to the parent.")) + + +(defgeneric parent (construct &key revision) + (:documentation "Returns the parent construct of the passed object that + corresponds with the given revision. The returned construct + can be a TopicC or a NameC.")) + + (defgeneric delete-if-not-referenced (construct) (:documentation "Calls delete-construct for the given object if it is not referenced by any other construct.")) @@ -1672,20 +1687,22 @@ :referenced-construct name :existing-reference (parent name :revision revision) :new-reference construct))) - (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))) - (add-to-version-history name-assoc :start-revision revision)) - (make-construct 'NameAssociationC - :parent-construct construct - :characteristic name - :start-revision revision))) - (add-to-version-history construct :start-revision revision) - construct)) + (if (merge-if-equivalent name construct :revision revision) + construct + (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))) + (add-to-version-history name-assoc :start-revision revision)) + (make-construct 'NameAssociationC + :parent-construct construct + :characteristic name + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) (defgeneric delete-name (construct name &key revision) @@ -1730,19 +1747,21 @@ :referenced-construct occurrence :existing-reference (parent occurrence :revision revision) :new-reference construct)) - (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))) - (add-to-version-history occ-assoc :start-revision revision)) - (make-construct 'OccurrenceAssociationC - :parent-construct construct - :characteristic occurrence - :start-revision revision))) - (add-to-version-history construct :start-revision revision) - construct)) + (if (merge-if-equivalent occurrence construct :revision revision) + construct + (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))) + (add-to-version-history occ-assoc :start-revision revision)) + (make-construct 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) (defgeneric delete-occurrence (construct occurrence &key revision) @@ -2000,8 +2019,9 @@ ;;; CharacteristicC (defmethod delete-if-not-referenced ((construct CharacteristicC)) (let ((references (slot-p construct 'parent))) - (when (and (<= (length references) 1) - (marked-as-deleted-p (first references))) + (when (or (not references) + (and (= (length references) 1) + (marked-as-deleted-p (first references)))) (delete-construct construct)))) @@ -2099,16 +2119,12 @@ t)) -(defgeneric parent (construct &key revision) - (:documentation "Returns the parent construct of the passed object that - corresponds with the given revision. The returned construct - can be a TopicC or a NameC.") - (:method ((construct CharacteristicC) &key (revision *TM-REVISION*)) - (let ((valid-associations - (filter-slot-value-by-revision construct 'parent - :start-revision revision))) - (when valid-associations - (parent-construct (first valid-associations)))))) +(defmethod parent ((construct CharacteristicC) &key (revision *TM-REVISION*)) + (let ((valid-associations + (filter-slot-value-by-revision construct 'parent + :start-revision revision))) + (when valid-associations + (parent-construct (first valid-associations))))) (defmethod add-parent ((construct CharacteristicC) @@ -2290,19 +2306,21 @@ :referenced-construct variant :existing-reference (parent variant :revision revision) :new-reference construct))) - (let ((all-variants - (map 'list #'characteristic (slot-p construct 'variants)))) - (if (find variant all-variants) - (let ((variant-assoc - (loop for variant-assoc in (slot-p construct 'variants) - when (eql (characteristic variant-assoc) variant) - return variant-assoc))) - (add-to-version-history variant-assoc :start-revision revision)) - (make-construct 'VariantAssociationC - :characteristic variant - :parent-construct construct - :start-revision revision))) - construct)) + (if (merge-if-equivalent variant construct :revision revision) + construct + (let ((all-variants + (map 'list #'characteristic (slot-p construct 'variants)))) + (if (find variant all-variants) + (let ((variant-assoc + (loop for variant-assoc in (slot-p construct 'variants) + when (eql (characteristic variant-assoc) variant) + return variant-assoc))) + (add-to-version-history variant-assoc :start-revision revision)) + (make-construct 'VariantAssociationC + :characteristic variant + :parent-construct construct + :start-revision revision)) + construct)))) (defgeneric delete-variant (construct variant &key revision) @@ -2417,20 +2435,22 @@ (:documentation "Adds the given role to the passed association-construct.") (:method ((construct AssociationC) (role RoleC) &key (revision *TM-REVISION*)) - (let ((all-roles - (map 'list #'role (slot-p construct 'roles)))) - (if (find role all-roles) - (let ((role-assoc - (loop for role-assoc in (slot-p construct 'roles) - when (eql (role role-assoc) role) - return role-assoc))) - (add-to-version-history role-assoc :start-revision revision)) - (make-construct 'RoleAssociationC - :role role - :parent-construct construct - :start-revision revision))) - (add-to-version-history construct :start-revision revision) - construct)) + (if (merge-if-equivalent role construct :revision revision) + construct + (let ((all-roles + (map 'list #'role (slot-p construct 'roles)))) + (if (find role all-roles) + (let ((role-assoc + (loop for role-assoc in (slot-p construct 'roles) + when (eql (role role-assoc) role) + return role-assoc))) + (add-to-version-history role-assoc :start-revision revision)) + (make-construct 'RoleAssociationC + :role role + :parent-construct construct + :start-revision revision)) + (add-to-version-history construct :start-revision revision) + construct)))) (defgeneric delete-role (construct role &key revision) @@ -2457,8 +2477,9 @@ ;;; RoleC (defmethod delete-if-not-referenced ((construct RoleC)) (let ((references (slot-p construct 'parent))) - (when (and (<= (length references) 1) - (marked-as-deleted-p (first references))) + (when (or (not references) + (and (= (length references) 1) + (marked-as-deleted-p (first references)))) (delete-construct construct)))) @@ -2988,7 +3009,7 @@ (:method ((construct ScopableC) (theme-topic TopicC) &key (revision (error (make-condition 'missing-argument-error :message "From delete-theme(): revision must be set" - :argument-symbol 'revsion + :argument-symbol 'revision :function-symbol 'delete-theme)))) (let ((assoc-to-delete (loop for theme-assoc in (slot-p construct 'themes) when (eql (theme-topic theme-assoc) theme-topic) @@ -3388,7 +3409,7 @@ (not start-revision)) (error (make-condition 'missing-argument-error :message "From make-characteristic(): start-revision must be set" - :argument-symbol 'start-revsion + :argument-symbol 'start-revision :function-symbol 'make-characgteristic))) (let ((characteristic (let ((existing-characteristic @@ -3895,4 +3916,59 @@ (move-referenced-constructs newer-role older-role :revision revision) (delete-if-not-referenced newer-role) - older-role))))))) \ No newline at end of file + older-role))))))) + + +(defmethod merge-if-equivalent ((new-role RoleC) (parent-construct AssociationC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (let ((possible-roles + (remove-if #'(lambda(role) + (when (parent role :revision revision) + role)) + (map 'list #'role (slot-p parent-construct 'roles))))) + (let ((equivalent-role + (remove-if + #'null + (map 'list + #'(lambda(role) + (when + (strictly-equivalent-constructs role new-role + :revision revision) + role)) + possible-roles)))) + (when equivalent-role + (merge-constructs (first equivalent-role) new-role + :revision revision))))) + + +(defmethod merge-if-equivalent ((new-characteristic CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision) (type (or TopicC NameC) parent-construct)) + (let ((all-existing-characteristics + (map 'list #'characteristic + (cond ((typep new-characteristic 'OccurrenceC) + (slot-p parent-construct 'occurrences)) + ((typep new-characteristic 'NameC) + (slot-p parent-construct 'names)) + ((typep new-characteristic 'VariantC) + (slot-p parent-construct 'variants)))))) + (let ((possible-characteristics ;all characteristics that are not referenced + ;other constructs at the given revision + (remove-if #'(lambda(char) + (parent char :revision revision)) + all-existing-characteristics))) + (let ((equivalent-construct + (remove-if + #'null + (map 'list + #'(lambda(char) + (when + (strictly-equivalent-constructs char new-characteristic + :revision revision) + char)) + possible-characteristics)))) + (when equivalent-construct + (merge-constructs (first equivalent-construct) new-characteristic + :revision revision)))))) \ No newline at end of file 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 Fri Apr 9 11:36:02 2010 @@ -2741,53 +2741,67 @@ (test test-find-oldest-construct () "Tests the generic find-oldest-construct." (with-fixture with-empty-db (*db-dir*) - (let ((top-1 (make-instance 'TopicC)) - (top-2 (make-instance 'TopicC)) - (tm-1 (make-instance 'TopicMapC)) - (tm-2 (make-instance 'TopicMapC)) - (assoc-1 (make-instance 'AssociationC)) - (assoc-2 (make-instance 'AssociationC)) - (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) - (variant-1 (make-instance 'VariantC)) - (variant-2 (make-instance 'VariantC)) - (name-1 (make-instance 'NameC)) - (name-2 (make-instance 'NameC)) - (role-1 (make-instance 'RoleC)) - (role-2 (make-instance 'RoleC)) - (rev-1 100) + (let ((rev-1 100) (rev-2 200) (rev-3 300)) - (setf *TM-REVISION* rev-1) - (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (add-item-identifier top-1 ii-1 :revision rev-3) - (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (add-item-identifier assoc-1 ii-2 :revision rev-2) - (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2))) - (add-item-identifier top-2 ii-1 :revision rev-1) - (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) - (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (add-variant name-1 variant-1 :revision rev-3) - (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (add-variant name-1 variant-2 :revision rev-2) - (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) - (add-variant name-2 variant-1 :revision rev-1) - (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) - (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (add-role assoc-1 role-1 :revision rev-3) - (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (add-role assoc-1 role-2 :revision rev-2) - (is (eql role-2 (d::find-oldest-construct role-1 role-2))) - (add-role assoc-2 role-1 :revision rev-1) - (is (eql role-1 (d::find-oldest-construct role-1 role-2))) - (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) - (d::add-to-version-history tm-1 :start-revision rev-3) - (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) - (d::add-to-version-history tm-2 :start-revision rev-1) - (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2))) - (d::add-to-version-history tm-1 :start-revision rev-1) - (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) - (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1)))))) + (let ((theme-1 (make-construct 'TopicC :start-revision rev-1)) + (theme-2 (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (player-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (tm-1 (make-instance 'TopicMapC)) + (tm-2 (make-instance 'TopicMapC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (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))) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (role-1 (make-construct 'RoleC + :start-revision rev-1 + :player player-1)) + (role-2 (make-construct 'RoleC + :start-revision rev-1 + :player player-2))) + (setf *TM-REVISION* rev-1) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier top-1 ii-1 :revision rev-3) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier assoc-1 ii-2 :revision rev-2) + (is (eql ii-2 (d::find-oldest-construct ii-1 ii-2))) + (add-item-identifier top-2 ii-1 :revision rev-1) + (is (eql ii-1 (d::find-oldest-construct ii-1 ii-2))) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (add-variant name-1 variant-1 :revision rev-3) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (add-variant name-1 variant-2 :revision rev-2) + (is (eql variant-2 (d::find-oldest-construct variant-1 variant-2))) ;x + (add-variant name-2 variant-1 :revision rev-1) + (is (eql variant-1 (d::find-oldest-construct variant-1 variant-2))) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) + (add-role assoc-1 role-1 :revision rev-3) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) ;x + (add-role assoc-1 role-2 :revision rev-2) + (is (eql role-2 (d::find-oldest-construct role-1 role-2))) + (add-role assoc-2 role-1 :revision rev-1) + (is (eql role-1 (d::find-oldest-construct role-1 role-2))) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-1 :start-revision rev-3) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-2 :start-revision rev-1) + (is (eql tm-2 (d::find-oldest-construct tm-1 tm-2))) + (d::add-to-version-history tm-1 :start-revision rev-1) + (is (eql tm-1 (d::find-oldest-construct tm-1 tm-2))) + (is (eql tm-2 (d::find-oldest-construct tm-2 tm-1)))))))) (test test-move-referenced-constructs-ReifiableConstructC ()