isidorus-cvs April 2010

isidorus-cvs@common-lisp.net

1 participants
38 discussions

[isidorus-cvs] r292 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 29 Apr '10

29 Apr '10

Author: lgiessmann Date: Thu Apr 29 11:07:06 2010 New Revision: 292 Log: new-datamodel: fixed two bugs in "merge-constructs" corresponding to "AssociationC" 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 Thu Apr 29 11:07:06 2010 @@ -4149,8 +4149,15 @@ (let ((newer-assoc (if (eql older-assoc construct-1) construct-2 construct-1))) - (unless (strictly-equivalent-constructs construct-1 construct-2 - :revision revision) + ;(unless (strictly-equivalent-constructs construct-1 construct-2 + ; :revision revision) + ;;associations that have different roles can be although merged, e.g. + ;;two roles are in two different association objects references + ;;the same item-identifier or reifier + (when (or (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision)) + (not (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)))) (error (make-condition 'not-mergable-error :message (format nil "From merge-constructs(): ~a and ~a are not mergable" construct-1 construct-2) @@ -4158,6 +4165,8 @@ :construct-2 construct-2))) (dolist (tm (in-topicmaps newer-assoc :revision revision)) (add-to-tm tm older-assoc)) + (delete-type newer-assoc (instance-of newer-assoc :revision revision) + :revision revision) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4165,10 +4174,14 @@ (strictly-equivalent-constructs older-role newer-role :revision revision)) (roles older-assoc :revision revision)))) - (move-referenced-constructs newer-role equivalent-role - :revision revision) + (when equivalent-role + (move-referenced-constructs newer-role equivalent-role + :revision revision)) (delete-role newer-assoc newer-role :revision revision) - (add-role older-assoc equivalent-role :revision revision))) + (add-role older-assoc (if equivalent-role + equivalent-role + newer-role) + :revision revision))) (mark-as-deleted newer-assoc :revision revision) (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) 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 Thu Apr 29 11:07:06 2010 @@ -90,7 +90,8 @@ :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 :test-merge-constructs-TopicC-9 - :test-merge-constructs-TopicC-10)) + :test-merge-constructs-TopicC-10 + :test-merge-constructs-AssociationC)) (declaim (optimize (debug 3))) @@ -2938,7 +2939,7 @@ (test test-merge-constructs-TopicC-1 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3051,7 +3052,7 @@ (test test-merge-constructs-TopicC-2 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3165,7 +3166,7 @@ (test test-merge-constructs-TopicC-3 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3265,7 +3266,7 @@ (test test-merge-constructs-TopicC-4 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3323,7 +3324,7 @@ (test test-merge-constructs-TopicC-5 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-3 300)) @@ -3381,7 +3382,7 @@ (test test-merge-constructs-TopicC-6 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3452,7 +3453,7 @@ (test test-merge-constructs-TopicC-7 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3521,7 +3522,7 @@ (test test-merge-constructs-TopicC-8 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3587,7 +3588,7 @@ (test test-merge-constructs-TopicC-9 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3641,7 +3642,7 @@ (test test-merge-constructs-TopicC-10 () - "Tests the generic move-referenced-constructs corresponding to TopicC." + "Tests the generic merge-constructs corresüponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) (rev-2 200) @@ -3716,12 +3717,82 @@ (is-false (set-exclusive-or (list variant-1) (variants name-1))) (is-false (set-exclusive-or (list variant-2) (variants name-4))) (is (= (length (d::versions top-1)) 2)))))))) - - - -;;TODO: merge associations caused by a merge of their roles +(test test-merge-constructs-AssociationC () + "Tests merge-constructs corresponding to AssociationC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-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)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((role-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-1)) + (role-2-1 (list :start-revision rev-1 + :player player-1 + :instance-of r-type-2)) + (role-2-2 (list :start-revision rev-2 + :player player-1 + :item-identifiers (list ii-2) + :instance-of r-type-2)) + (role-3 (list :start-revision rev-2 + :player player-2 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :instance-of r-type-2))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :roles (list role-1 role-2-1))) + (assoc-2 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-2-2 role-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-associations nil)) 2)) + (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-1 + :roles (list role-1 role-2-1)) + (is (= (length (get-all-associations nil)) 2)) + (let ((role-2-1-inst + (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1))) + (roles assoc-1)))) + (is-true role-2-1-inst) + (is (eql (add-item-identifier role-2-1-inst ii-2) role-2-1-inst)) + (is-true (marked-as-deleted-p assoc-2)) + (is-false (roles assoc-2)) + (is-false (instance-of assoc-2)) + (is-false (themes assoc-2)) + (is (eql (instance-of assoc-2 :revision rev-2) type-1)) + (is (= (length (roles assoc-1)) 3)) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-1))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-1) + (eql (player role) player-2) + (not (set-exclusive-or + (list ii-1) + (item-identifiers role))))) + (roles assoc-1))) + (is-true (find-if #'(lambda(role) + (and (eql (instance-of role) r-type-2) + (eql (player role) player-1) + (not (set-exclusive-or + (list ii-2) + (item-identifiers role))))) + (roles assoc-1)))))))))) (defun run-datamodel-tests() @@ -3792,4 +3863,4 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) - ) \ No newline at end of file + (it.bese.fiveam:run! 'test-merge-constructs-AssociationC)) \ No newline at end of file

1 0

[isidorus-cvs] r291 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 29 Apr '10

29 Apr '10

Author: lgiessmann Date: Thu Apr 29 06:47:46 2010 New Revision: 291 Log: new-datamodel: fixed a bug when merging topics by adding an item-identifier to two different variants of the topic's names that are mergable 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 Thu Apr 29 06:47:46 2010 @@ -4101,7 +4101,10 @@ (find older-char (variants name :revision revision))) - (names active-parent :revision revision)))))) + (if (parent active-parent :revision revision) + (names (parent active-parent :revision revision) + :revision revision) + (list active-parent))))))) (if found-older-char older-char newer-char)))) 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 Thu Apr 29 06:47:46 2010 @@ -89,13 +89,8 @@ :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 :test-merge-constructs-TopicC-8 - :test-merge-constructs-TopicC-9)) - - -;;TODO: test merge-constructs --> associations when merge was caused by -;; item-identifier of two roles -;;TODO: test mark-as-deleted - + :test-merge-constructs-TopicC-9 + :test-merge-constructs-TopicC-10)) (declaim (optimize (debug 3))) @@ -3644,8 +3639,87 @@ (is-false (set-exclusive-or (list occ-2) (occurrences top-2)))))))) -;;TODO: merge topics caused by variant-item-identifiers -;;TODO: merge associations caused by a merge of their characteristics + +(test test-merge-constructs-TopicC-10 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list psi-1))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :psis (list psi-2))) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-1 (make-construct 'TopicC :start-revision rev-1))) + (let ((name-1 (make-construct 'NameC + :start-revision rev-1 + :instance-of nil + :charvalue "name" + :themes (list scope-1) + :item-identifiers (list ii-1) + :parent top-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :instance-of type-1 + :charvalue "name" + :themes (list scope-1) + :parent top-1)) + (name-3 (make-construct 'NameC + :start-revision rev-2 + :instance-of nil + :charvalue "name" + :themes (list scope-1) + :item-identifiers (list ii-2) + :parent top-2)) + (name-4 (make-construct 'NameC + :start-revision rev-2 + :instance-of type-1 + :charvalue "name" + :themes nil + :parent top-2))) + (let ((variant-1 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "variant" + :themes (list scope-1) + :item-identifiers (list ii-3 ii-4) + :parent name-1)) + (variant-2 (make-construct 'VariantC + :start-revision rev-1 + :charvalue "variant" + :themes (list scope-1) + :parent name-4)) + (variant-3 (make-construct 'VariantC + :start-revision rev-2 + :charvalue "variant" + :themes (list scope-1) + :parent name-3))) + (setf *TM-REVISION* rev-3) + (signals not-mergable-error (add-item-identifier variant-2 ii-4)) + (is-false (marked-as-deleted-p top-2)) + (is-false (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p name-4)) + (is (eql (add-item-identifier variant-3 ii-4) variant-1)) + (is-true (marked-as-deleted-p top-2)) + (is-false (names top-2)) + (is-false (psis top-2)) + (is-false (set-exclusive-or (list name-1 name-2 name-4) (names top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list variant-1) (variants name-1))) + (is-false (set-exclusive-or (list variant-2) (variants name-4))) + (is (= (length (d::versions top-1)) 2)))))))) + + + +;;TODO: merge associations caused by a merge of their roles @@ -3717,4 +3791,5 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10) ) \ No newline at end of file

1 0

[isidorus-cvs] r290 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 29 Apr '10

29 Apr '10

Author: lgiessmann Date: Thu Apr 29 06:17:20 2010 New Revision: 290 Log: new-datamodel: fixed a problem when topic-merging was caused by reifying the same "ReifiableConstructC"; fixed a bug when two topics are merged and every of these topics reifies a construct that can't be merged with the other one. 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 Thu Apr 29 06:17:20 2010 @@ -3086,6 +3086,15 @@ the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) &key (revision *TM-REVISION*)) + (when (and (reified-construct reifier-topic :revision revision) + (not (equivalent-constructs construct + (reified-construct + reifier-topic :revision revision)))) + (error (make-condition 'not-mergable-error + :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" + reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) + :construct-1 construct + :construct-2 (reified-construct reifier-topic :revision revision)))) (let ((merged-reifier-topic (if (reifier construct :revision revision) (merge-constructs (reifier construct :revision revision) @@ -3852,7 +3861,9 @@ (let ((source-reified (reified-construct source :revision revision)) (destination-reified (reified-construct destination :revision revision))) - (unless (eql (type-of source-reified) (type-of destination-reified)) + (when (and source-reified destination-reified + (not (eql (type-of source-reified) + (type-of destination-reified)))) (error (make-condition 'not-mergable-error :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" source destination source-reified destination-reified) @@ -3868,10 +3879,10 @@ merged-reified)) (source-reified (delete-reifier source source-reified :revision revision) - (add-reifier destination source-reified :revision revision) + (add-reifier source-reified destination :revision revision) source-reified) (destination-reified - (add-reifier destination destination-reified :revision revision) + (add-reifier destination-reified destination :revision revision) destination-reified))))) 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 Thu Apr 29 06:17:20 2010 @@ -88,7 +88,8 @@ :test-merge-constructs-TopicC-5 :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 - :test-merge-constructs-TopicC-8)) + :test-merge-constructs-TopicC-8 + :test-merge-constructs-TopicC-9)) ;;TODO: test merge-constructs --> associations when merge was caused by @@ -3554,12 +3555,96 @@ (setf *TM-REVISION* rev-3) (signals not-mergable-error (add-reifier occ-3 reifier-1)) (is (eql (add-reifier occ-2 reifier-1) occ-1)) + (is-false (set-exclusive-or (list occ-1 occ-3) (occurrences top-1))) (is-true (marked-as-deleted-p top-2)) - (is-true (marked-as-deleted-p occ-2))))))) + (is-true (marked-as-deleted-p occ-2)) + (is (= (length (d::versions top-1)) 2)) + (is (= (length (d::versions top-2)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (d::versions top-2))) + (is (= (length (slot-value occ-2 'd::parent)) 1)) + (is (= (length (slot-value occ-1 'd::parent)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (first (map 'list #'d::versions + (slot-value occ-2 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent)))))))))) + + +(test test-merge-constructs-TopicC-9 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))) + (let ((top-1 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-2))) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (top-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (reifier-2 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-1))) + (reifier-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-4 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-2 + :charvalue "occ" + :reifier reifier-3 + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-4 + :parent top-3))) + (setf *TM-REVISION* rev-3) + (is (eql (reifier occ-2) reifier-3)) + (signals not-mergable-error (add-reifier occ-1 reifier-3)) + (is (eql occ-1 (add-reifier occ-1 reifier-2))) + (is-true (marked-as-deleted-p reifier-2)) + (is-false (set-exclusive-or (list psi-1) (psis reifier-1))) + (setf *TM-REVISION* rev-4) + (is (eql (add-reifier occ-1 reifier-4) occ-3)) + (is-true (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p top-3)) + (is-false (set-exclusive-or (list psi-2) (psis top-3))) + (is-false (marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list occ-2) (occurrences top-2)))))))) ;;TODO: merge topics caused by variant-item-identifiers -;;TODO: mrege topics caused by reifying the same reified-construct ;;TODO: merge associations caused by a merge of their characteristics @@ -3631,4 +3716,5 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) ) \ No newline at end of file

1 0

[isidorus-cvs] r289 - trunk/src/json
by Lukas Giessmann 28 Apr '10

28 Apr '10

Author: lgiessmann Date: Wed Apr 28 05:35:03 2010 New Revision: 289 Log: json-exporter: fixed a bug in the function "get-all-topics" Modified: trunk/src/json/json_exporter.lisp Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Wed Apr 28 05:35:03 2010 @@ -298,8 +298,10 @@ (remove-if #'null (map 'list #'(lambda(psi-list) (when psi-list (map 'list #'uri psi-list))) - (clean-topics - (elephant:get-instances-by-class 'TopicC)))))) + (map 'list + #'d:psis + (clean-topics + (elephant:get-instances-by-class 'TopicC))))))) (defun to-json-string-summary (topic)

1 0

[isidorus-cvs] r288 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 27 Apr '10

27 Apr '10

Author: lgiessmann Date: Tue Apr 27 15:51:47 2010 New Revision: 288 Log: new-datamodel: fixed bugs in the function: "add-item-identifier", "add-variant" and "make-topic"; added new unit-tests 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 Tue Apr 27 15:51:47 2010 @@ -98,7 +98,7 @@ :charvalue :reified-construct :mark-as-deleted - :mark-as-deleted-p + :marked-as-deleted-p :in-topicmaps :delete-construct :get-revision @@ -152,6 +152,7 @@ :get-all-associations :get-all-tms + ;;globals :*TM-REVISION* :*CURRENT-XTM*)) @@ -159,11 +160,8 @@ (in-package :datamodel) +;;TODO: remove-<xy> --> add to version history??? ;;TODO: adapt changes-lisp -;;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-constructs, that merges constructs ;; after all operations in the body were called @@ -2483,6 +2481,9 @@ :characteristic variant :parent-construct construct :start-revision revision)) + (when (parent construct :revision revision) + (add-name (parent construct :revision revision) construct + :revision revision)) construct)))) @@ -3046,8 +3047,16 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (when (typep construct 'VersionedConstructC) - (add-to-version-history merged-construct :start-revision revision)) + (cond ((typep merged-construct 'VersionedConstructC) + (add-to-version-history merged-construct :start-revision revision)) + ((and (typep merged-construct 'CharacteristicC) + (parent merged-construct :revision revision)) + (add-characteristic (parent merged-construct :revision revision) + merged-construct :revision revision)) + ((and (typep merged-construct 'RoleC) + (parent merged-construct :revision revision)) + (add-role (parent merged-construct :revision revision) + merged-construct :revision revision))) merged-construct)))) @@ -3086,9 +3095,11 @@ (slot-p reifier-topic 'reified-construct)))) (let ((merged-construct construct)) (cond ((reified-construct merged-reifier-topic :revision revision) - (merge-constructs - (reified-construct merged-reifier-topic :revision revision) - construct)) + (let ((merged-reified + (merge-constructs + (reified-construct merged-reifier-topic + :revision revision) construct))) + (setf merged-construct merged-reified))) ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in @@ -3578,7 +3589,8 @@ (item-identifiers (getf args :item-identifiers)) (topic-identifiers (getf args :topic-identifiers)) (names (getf args :names)) - (occurrences (getf args :occurrences))) + (occurrences (getf args :occurrences)) + (reified-construct (getf args :refied-construct))) (when (and (or psis locators item-identifiers topic-identifiers names occurrences) (not start-revision)) @@ -3620,6 +3632,9 @@ :revision start-revision))) (dolist (occ occurrences) (add-occurrence merged-topic occ :revision start-revision)) + (when reified-construct + (add-reified-construct merged-topic reified-construct + :revision start-revision)) merged-topic)))) @@ -3724,26 +3739,6 @@ (add-locator identified-construct identifier :revision start-revision)))) identifier))) - - - - - - - - - - - - - - - - - - - - ;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 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 Tue Apr 27 15:51:47 2010 @@ -86,10 +86,13 @@ :test-merge-constructs-TopicC-3 :test-merge-constructs-TopicC-4 :test-merge-constructs-TopicC-5 - :test-merge-constructs-TopicC-6)) + :test-merge-constructs-TopicC-6 + :test-merge-constructs-TopicC-7 + :test-merge-constructs-TopicC-8)) -;;TODO: test merge-constructs +;;TODO: test merge-constructs --> associations when merge was caused by +;; item-identifier of two roles ;;TODO: test mark-as-deleted @@ -3452,13 +3455,113 @@ "ii-1"))))))))) +(test test-merge-constructs-TopicC-7 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (tid-1 (make-construct 'TopicIdentificationC + :uri "tid-1" :xtm-id "xtm-1")) + (tid-2 (make-construct 'TopicIdentificationC + :uri "tid-2" :xtm-id "xtm-2")) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-1 (make-construct 'TopicC :start-revision rev-1)) + (scope-2 (make-construct 'TopicC :start-revision rev-1)) + (top-1 (make-construct 'TopicC + :start-revision rev-1 + :psis (list psi-1) + :topic-identifiers (list tid-1))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :locators (list sl-1) + :topic-identifiers (list tid-2)))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :instance-of type-1 + :themes (list scope-1 scope-2) + :charvalue "occ" + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :item-identifiers (list ii-2) + :instance-of type-1 + :themes (list scope-1 scope-2) + :charvalue "occ" + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-3) + :instance-of type-1 + :themes (list scope-1) + :charvalue "occ" + :parent top-1))) + (setf *TM-REVISION* rev-3) + (is (= (length (get-all-topics rev-1)) 4)) + (is (= (length (get-all-topics rev-3)) 5)) + (is (= (length (d::get-db-instances-by-class + 'd::OccurrenceC :revision nil)) 3)) + (signals not-mergable-error (add-item-identifier occ-3 ii-1)) + (is (eql occ-1 (add-item-identifier occ-1 ii-2))) + (is (= (length (get-all-topics rev-3)) 4)) + (is-true (d::marked-as-deleted-p occ-2)) + (is-true (d::marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers occ-1))) + (is-false (item-identifiers occ-2)) + (is-false (set-exclusive-or (list ii-2) + (item-identifiers occ-2 :revision rev-2))) + (is-false (set-exclusive-or (list psi-1) (psis top-1))) + (is-false (set-exclusive-or (list sl-1) (locators top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (locators top-2))))))) +(test test-merge-constructs-TopicC-8 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((top-1 (make-construct 'TopicC :start-revision rev-1)) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-1 + :charvalue "occ" + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-2 + :charvalue "occ" + :parent top-1))) + (setf *TM-REVISION* rev-3) + (signals not-mergable-error (add-reifier occ-3 reifier-1)) + (is (eql (add-reifier occ-2 reifier-1) occ-1)) + (is-true (marked-as-deleted-p top-2)) + (is-true (marked-as-deleted-p occ-2))))))) + +;;TODO: merge topics caused by variant-item-identifiers +;;TODO: mrege topics caused by reifying the same reified-construct +;;TODO: merge associations caused by a merge of their characteristics -;;TODO: merge topics/associations caused by a merge of their characteristics -;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified -;; by the same reifier @@ -3526,4 +3629,6 @@ (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8) ) \ No newline at end of file

1 0

[isidorus-cvs] r287 - branches/new-datamodel/src/model
by Lukas Giessmann 23 Apr '10

23 Apr '10

Author: lgiessmann Date: Fri Apr 23 15:51:28 2010 New Revision: 287 Log: new-datamodel: fixed a versioningproblem in "merge-constructs" --> CharacteristicC 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 Fri Apr 23 15:51:28 2010 @@ -159,9 +159,6 @@ (in-package :datamodel) -;;TODO: replace add-<xy> + add-parent in all merge-constructs where the -;; characteristics are readded to make sure they are added to the current -;; version --> collidates with merge-if-equivalent!!! in merge-constructs ;;TODO: adapt changes-lisp ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs @@ -4067,6 +4064,18 @@ :revision revision) (delete-characteristic parent-2 newer-char :revision revision) + (let ((c-assoc + (find-if + #'(lambda(c-assoc) + (and (eql (characteristic c-assoc) older-char) + (eql (parent-construct c-assoc) parent-1))) + (cond ((typep older-char 'OccurrenceC) + (slot-p parent-1 'occurrences)) + ((typep older-char 'NameC) + (slot-p parent-1 'names)) + ((typep older-char 'VariantC) + (slot-p parent-1 'variants)))))) + (add-to-version-history c-assoc :start-revision revision)) older-char) ((and parent-1 parent-2) (let ((active-parent (merge-constructs parent-1 parent-2 @@ -4185,7 +4194,8 @@ (and (eql (role r-assoc) older-role) (eql (parent-construct r-assoc) parent-1))) (slot-p parent-1 'roles)))) - (add-to-version-history r-assoc :start-revision revision))) + (add-to-version-history r-assoc :start-revision revision) + older-role)) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision revision)))

1 0

[isidorus-cvs] r286 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 23 Apr '10

23 Apr '10

Author: lgiessmann Date: Fri Apr 23 14:47:37 2010 New Revision: 286 Log: new-datamodel: fixed an elephant bug that appears in the current version --> "get-instances-by-class" is embraced within a function that filters all instances by typep and optional a given revision; fixed a potential versioning bug in "merge-all-constructs"; fixed a bug in "equivalent-construct" --> AssociationC; fixed a bug in "merge-changed-constructs"; fixed a bug in "merge-constructs" --> the returned association object is added to the union of all tms the given associations were present in; added some unit-tests 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 23 14:47:37 2010 @@ -148,6 +148,9 @@ :check-for-duplicate-identifiers :find-item-by-content :rec-remf + :get-all-topics + :get-all-associations + :get-all-tms ;;globals :*TM-REVISION* @@ -156,10 +159,10 @@ (in-package :datamodel) - -;;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: replace add-<xy> + add-parent in all merge-constructs where the +;; characteristics are readded to make sure they are added to the current +;; version --> collidates with merge-if-equivalent!!! in merge-constructs +;;TODO: adapt changes-lisp ;;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), @@ -701,6 +704,34 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun get-db-instances-by-class (class-symbol &key (revision *TM-REVISION*)) + "Returns all instances of the given type and the given revision that are + stored in the db." + (declare (symbol class-symbol) (type (or null integer) revision)) + (let ((db-instances (elephant:get-instances-by-class class-symbol))) + (let ((filtered-instances (remove-if-not #'(lambda(inst) + (typep inst class-symbol)) + db-instances))) + (if revision + (remove-if #'null + (map 'list #'(lambda(inst) + (find-item-by-revision inst revision)) + filtered-instances)) + filtered-instances)))) + + +(defun get-all-topics (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicC :revision revision)) + + +(defun get-all-associations (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'AssociationC :revision revision)) + + +(defun get-all-tms (&optional (revision *TM-REVISION*)) + (get-db-instances-by-class 'TopicMapC :revision revision)) + + (defun find-version-info (versioned-constructs &key (sort-function #'<) (sort-key 'start-revision)) "Returns all version-infos sorted by the function sort-function which is @@ -811,14 +842,15 @@ (condition () nil))) -(defun merge-all-constructs(constructs-to-be-merged) +(defun merge-all-constructs(constructs-to-be-merged &key (revision *TM-REVISION*)) "Merges all constructs contained in the given list." (declare (list constructs-to-be-merged)) (let ((constructs-to-be-merged (subseq constructs-to-be-merged 1)) (merged-construct (elt constructs-to-be-merged 0))) (loop for construct-to-be-merged in constructs-to-be-merged do (setf merged-construct - (merge-constructs merged-construct construct-to-be-merged))))) + (merge-constructs merged-construct construct-to-be-merged + :revision revision))))) (defgeneric internal-id (construct) @@ -980,7 +1012,7 @@ ;;; VersionedConstructC -(defgeneric exist-in-revision-history-? (versioned-construct) +(defgeneric exist-in-version-history-p (versioned-construct) (:documentation "Returns t if the passed construct does not exist in any revision, i.e. the construct has no version-infos or exactly one whose start-revision is equal to its end-revision.") @@ -1106,8 +1138,16 @@ (let ((last-version ;the last active version (find 0 (versions construct) :key #'end-revision))) - (when last-version - (setf (end-revision last-version) revision)))) + (if (and last-version + (= (start-revision last-version) revision)) + (progn + (delete-construct last-version) + (let ((sorted-versions + (sort (versions construct) #'> :key #'end-revision))) + (when sorted-versions + (setf (end-revision (first sorted-versions)) revision)))) + (when last-version + (setf (end-revision last-version) revision))))) ;;; TopicMapconstructC @@ -2494,9 +2534,14 @@ (and (eql (instance-of construct-1 :revision revision) (instance-of construct-2 :revision revision)) (not (set-exclusive-or (themes construct-1 :revision revision) - (themes construct-1 :revision revision))) - (not (set-exclusive-or (roles construct-1 :revision revision) - (roles construct-2 :revision revision))))) + (themes construct-2 :revision revision))) + + (not (set-exclusive-or + (roles construct-1 :revision revision) + (roles construct-2 :revision revision) + :test #'(lambda(role-1 role-2) + (strictly-equivalent-constructs role-1 role-2 + :revision revision)))))) (defgeneric AssociationC-p (class-symbol) @@ -2517,21 +2562,22 @@ (type (or null TopicC) instance-of)) ;; item-identifiers and reifers are not checked because the equality have to ;; be variafied without them - (let ((checked-roles - (loop for assoc-role in (roles construct :revision start-revision) - when (loop for plist in roles - when (equivalent-construct - assoc-role :player (getf plist :player) - :start-revision (or (getf plist :start-revision) - start-revision) - :instance-of (getf plist :instance-of)) - return t) - collect assoc-role))) + (let ((checked-roles nil)) + (loop for plist in roles + do (let ((found-role + (find-if #'(lambda(assoc-role) + (equivalent-construct + assoc-role :player (getf plist :player) + :start-revision (or (getf plist :start-revision) + start-revision) + :instance-of (getf plist :instance-of))) + (roles construct :revision start-revision)))) + (when found-role + (push found-role checked-roles)))) (and (not (set-exclusive-or (roles construct :revision start-revision) checked-roles)) - (= (length (roles construct :revision start-revision)) - (length roles)) + (= (length checked-roles) (length roles)) (equivalent-typable-construct construct instance-of :start-revision start-revision) (equivalent-scopable-construct construct themes @@ -3428,9 +3474,10 @@ :roles roles :themes themes :instance-of instance-of) existing-association)) - (elephant:get-instances-by-class 'AssociationC))))) + (get-all-associations nil))))) (cond ((> (length existing-associations) 1) - (merge-all-constructs existing-associations)) + (merge-all-constructs existing-associations + :revision start-revision)) (existing-associations (first existing-associations)) (t @@ -3512,9 +3559,9 @@ :item-identifiers item-identifiers :reifier reifier) existing-tm)) - (elephant:get-instances-by-class 'TopicMapC))))) + (get-all-tms start-revision))))) (cond ((> (length existing-tms) 1) - (merge-all-constructs existing-tms)) + (merge-all-constructs existing-tms :revision start-revision)) (existing-tms (first existing-tms)) (t @@ -3554,9 +3601,9 @@ :item-identifiers item-identifiers :topic-identifiers topic-identifiers) existing-topic)) - (elephant:get-instances-by-class 'TopicC))))) + (get-all-topics start-revision))))) (cond ((> (length existing-topics) 1) - (merge-all-constructs existing-topics)) + (merge-all-constructs existing-topics :revision start-revision)) (existing-topics (first existing-topics)) (t @@ -3919,23 +3966,61 @@ (let ((parent (when (or (typep construct 'RoleC) (typep construct 'CharacteristicC)) (parent construct :revision revision)))) - (let ((found-equivalent - (find-if #'(lambda(other-construct) - (strictly-equivalent-constructs - other-construct construct :revision revision)) - (cond ((typep construct 'OccurrenceC) - (occurrences parent :revision revision)) - ((typep construct 'NameC) - (names parent :revision revision)) - ((typep construct 'VariantC) - (variants parent :revision revision)) - ((typep construct 'RoleC) - (roles parent :revision revision)) - ((typep construct 'AssociationC) - (elephant:get-instances-by-class 'AssociationC)))))) - (when found-equivalent - (merge-all-constructs (append found-equivalent (list construct)))))))) - + (let ((all-other (cond ((typep construct 'OccurrenceC) + (occurrences parent :revision revision)) + ((typep construct 'NameC) + (names parent :revision revision)) + ((typep construct 'VariantC) + (variants parent :revision revision)) + ((typep construct 'RoleC) + (roles parent :revision revision))))) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(other) + (when (strictly-equivalent-constructs + construct other :revision revision) + other)) + all-other)))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list construct)) + :revision revision)))))) + (merge-changed-associations older-topic :revision revision)) + + +(defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) + "Merges all associations that became TMDM-equal since two referenced topics + were merged, e.g. the association types." + (declare (TopicC older-topic)) + (let ((all-assocs + (remove-duplicates + (append + (remove-if + #'null + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles older-topic :revision revision))) + (remove-if + #'null + (map + 'list #'(lambda(constr) + (when (typep constr 'AssociationC) + constr)) + (append (used-as-type older-topic :revision revision) + (used-as-theme older-topic :revision revision)))))))) + (dolist (assoc all-assocs) + (let ((all-equivalent + (remove-if + #'null + (map 'list #'(lambda(db-assoc) + (when (strictly-equivalent-constructs + assoc db-assoc :revision revision) + db-assoc)) + (get-all-associations nil))))) + (when all-equivalent + (merge-all-constructs (append all-equivalent (list assoc)) + :revision revision)))))) + (defmethod merge-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) @@ -3953,7 +4038,7 @@ (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) (mark-as-deleted newer-topic :revision revision :source-locator nil) - (when (exist-in-revision-history-? newer-topic) + (when (exist-in-version-history-p newer-topic) (delete-construct newer-topic)) older-topic)))) @@ -3980,7 +4065,7 @@ (cond ((and parent-1 (eql parent-1 parent-2)) (move-referenced-constructs newer-char older-char :revision revision) - (delete-characteristic newer-char parent-2 + (delete-characteristic parent-2 newer-char :revision revision) older-char) ((and parent-1 parent-2) @@ -4032,7 +4117,7 @@ (add-to-tm top-or-assoc top-or-assoc)) (add-to-version-history older-tm :start-revision revision) (mark-as-deleted newer-tm :revision revision) - (when (exist-in-revision-history-? newer-tm) + (when (exist-in-version-history-p newer-tm) (delete-construct newer-tm)) older-tm)))) @@ -4053,6 +4138,8 @@ construct-1 construct-2) :construct-1 construct-1 :construct-2 construct-2))) + (dolist (tm (in-topicmaps newer-assoc :revision revision)) + (add-to-tm tm older-assoc)) (move-referenced-constructs newer-assoc older-assoc) (dolist (newer-role (roles newer-assoc :revision revision)) (let ((equivalent-role @@ -4065,7 +4152,7 @@ (delete-role newer-assoc newer-role :revision revision) (add-role older-assoc equivalent-role :revision revision))) (mark-as-deleted newer-assoc :revision revision) - (when (exist-in-revision-history-? newer-assoc) + (when (exist-in-version-history-p newer-assoc) (delete-construct newer-assoc)) older-assoc)))) @@ -4091,8 +4178,14 @@ (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)) + (delete-role parent-2 newer-role :revision revision) + (let ((r-assoc + (find-if + #'(lambda(r-assoc) + (and (eql (role r-assoc) older-role) + (eql (parent-construct r-assoc) parent-1))) + (slot-p parent-1 'roles)))) + (add-to-version-history r-assoc :start-revision revision))) ((and parent-1 parent-2) (let ((active-assoc (merge-constructs parent-1 parent-2 :revision revision))) 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 23 14:47:37 2010 @@ -81,7 +81,12 @@ :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC :test-move-referenced-constructs-NameC - :test-merge-constructs-TopicC-1)) + :test-merge-constructs-TopicC-1 + :test-merge-constructs-TopicC-2 + :test-merge-constructs-TopicC-3 + :test-merge-constructs-TopicC-4 + :test-merge-constructs-TopicC-5 + :test-merge-constructs-TopicC-6)) ;;TODO: test merge-constructs @@ -1815,7 +1820,7 @@ :start-revision rev-1)) (role-2 (list :player player-2 :instance-of r-type-2 :start-revision rev-1)) - (role-3 (list :instance-of r-type-3 :player player-3 + (role-3 (list :player player-3 :instance-of r-type-3 :start-revision rev-1)) (type-1 (make-instance 'd:TopicC)) (type-2 (make-instance 'd:TopicC)) @@ -1877,7 +1882,7 @@ (is-false (d::strictly-equivalent-constructs assoc-1 assoc-3)) (is-false (d::strictly-equivalent-constructs assoc-1 assoc-4)) (is-false (d::strictly-equivalent-constructs assoc-1 assoc-5)) - (is-false (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) + (is-true (d::strictly-equivalent-constructs assoc-1 assoc-6))))))) (test test-equivalent-TopicC () @@ -3046,6 +3051,414 @@ (is-true (d::marked-as-deleted-p occ-3)))))))))) +(test test-merge-constructs-TopicC-2 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (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-2 + :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-2 + :item-identifiers (list ii-3) + :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)) + (name-2 (make-construct 'NameC + :start-revision rev-2 + :charvalue "name-2" + :instance-of type-1 + :variants (list variant-1 variant-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1 + :variants (list variant-3)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :topic-identifiers (list tid-1) + :item-identifiers (list ii-1) + :locators (list sl-1) + :psis (list psi-1) + :names (list name-1 name-2) + :occurrences (list occ-1 occ-2))) + (top-2 (make-construct 'TopicC + :start-revision rev-3 + :topic-identifiers (list tid-2) + :item-identifiers (list ii-2) + :locators (list sl-2) + :psis (list psi-2) + :names (list name-3) + :occurrences (list occ-3)))) + (setf *TM-REVISION* rev-3) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (is (eql top top-1)) + (is-false (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers top-1))) + (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (set-exclusive-or (list psi-1) + (psis top-1 :revision rev-2))) + (is-false (set-exclusive-or (list name-1 name-2) + (names top-1))) + (is-false (set-exclusive-or (variants name-1) + (list variant-3))) + (is-false (variants name-3)) + (is-false (set-exclusive-or (occurrences top-1) + (list occ-1 occ-2))) + (is-false (set-exclusive-or (item-identifiers occ-1) + (list ii-3))) + (is-false (item-identifiers occ-3)) + (is-true (d::marked-as-deleted-p name-3)) + (is-true (d::marked-as-deleted-p occ-3)))))))))) + + +(test test-merge-constructs-TopicC-3 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (n-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")) + (ii-5 (make-construct 'ItemIdentifierC :uri "ii-5")) + (ii-6 (make-construct 'ItemIdentifierC :uri "ii-6")) + (var-0-1 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1")) + (var-0-2 + (make-construct 'VariantC + :start-revision rev-1 + :themes (list + (make-construct 'TopicC + :start-revision rev-1)) + :charvalue "var-0-1"))) + (let ((occ-1 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-1) + :charvalue "occ" + :instance-of type-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-1 + :item-identifiers (list ii-2) + :charvalue "occ" + :instance-of type-2)) + (name-1 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-3) + :variants (list var-0-1) + :charvalue "name" + :instance-of type-1)) + (name-2 (make-construct 'NameC + :start-revision rev-1 + :item-identifiers (list ii-4) + :variants (list var-0-2) + :charvalue "name" + :instance-of type-2)) + (var-1 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-5) + :charvalue "var" + :themes (list type-1))) + (var-2 (make-construct 'VariantC + :start-revision rev-1 + :item-identifiers (list ii-6) + :charvalue "var" + :themes (list type-2)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :occurrences (list occ-1 occ-2) + :names (list name-1 name-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-3" + :instance-of n-type + :variants (list var-1 var-2)))) + (let ((top-2 (make-construct 'TopicC + :start-revision rev-1 + :names (list name-3)))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (occurrences top-1)) 1)) + (is-false (set-exclusive-or + (list ii-1 ii-2) + (item-identifiers (first (occurrences top-1))))) + (is (= (length (slot-value top-1 'd::occurrences)) 2)) + (is (= (length (names top-1)) 1)) + (is-false (set-exclusive-or + (list ii-3 ii-4) + (item-identifiers (first (names top-1))))) + (is (= (length (slot-value top-1 'd::names)) 2)) + (is-false (set-exclusive-or (list var-0-1 var-0-2) + (variants (first (names top-1))))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(occ) + (eql occ (first (occurrences top-1)))) + (slot-value top-1 'd::occurrences)))) + (is-true (d::marked-as-deleted-p + (find-if-not #'(lambda(name) + (eql name (first (names top-1)))) + (slot-value top-1 'd::names)))) + (is (= (length (variants (first (names top-2)))) 1)) + (is (= (length (slot-value (first (names top-2)) 'd::variants)) 2)) + (is (eql (first (themes (first (variants (first (names top-2)))))) + type-1))))))))) + + +(test test-merge-constructs-TopicC-4 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (r-type (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player type-1 + :instance-of r-type + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player type-2 + :item-identifiers (list ii-2) + :instance-of r-type + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-1)) 1)) + (is (= (length (slot-value assoc-1 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-1))) r-type)) + (is (eql (player (first (roles assoc-1))) type-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-1))))) + (let ((active-role (first (roles assoc-1))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-1)))) + (slot-value assoc-1 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-5 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (a-type (make-construct 'TopicC :start-revision rev-1)) + (player-1 (make-construct 'TopicC :start-revision rev-1)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))) + (let ((assoc-2 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of a-type + :roles (list (list :player player-1 + :instance-of type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-1 + :item-identifiers (list ii-2) + :instance-of type-2 + :start-revision rev-1))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (roles assoc-2)) 1)) + (is (= (length (slot-value assoc-2 'd::roles)) 2)) + (is (eql (instance-of (first (roles assoc-2))) type-1)) + (is (eql (player (first (roles assoc-2))) player-1)) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers (first (roles assoc-2))))) + (let ((active-role (first (roles assoc-2))) + (non-active-role + (let ((r-assoc (find-if-not #'(lambda(role) + (eql role (first (roles assoc-2)))) + (slot-value assoc-2 'd::roles)))) + (when r-assoc + (d::role r-assoc))))) + (is (= (length (d::versions + (first (slot-value active-role 'd::parent)))) 2)) + (is (= (length (d::versions + (first (slot-value non-active-role 'd::parent)))) 1)) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value non-active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-1 (d::start-revision vi)) + (= rev-3 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= rev-3 (d::start-revision vi)) + (= 0 (d::end-revision vi)))) + (d::versions (first (slot-value active-role + 'd::parent))))))))))) + + +(test test-merge-constructs-TopicC-6 () + "Tests the generic move-referenced-constructs corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (rev-2 200) + (rev-3 300)) + (let ((type-1 (make-construct 'TopicC :start-revision rev-1)) + (type-2 (make-construct 'TopicC :start-revision rev-1)) + (r-type-1 (make-construct 'TopicC :start-revision rev-1)) + (r-type-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)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4"))) + (let ((assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :item-identifiers (list ii-3) + :roles (list (list :player player-1 + :instance-of r-type-1 + :item-identifiers (list ii-1) + :start-revision rev-1) + (list :player player-2 + :instance-of r-type-2 + :start-revision rev-1)))) + (assoc-4 (make-construct 'AssociationC + :start-revision rev-2 + :instance-of type-2 + :item-identifiers (list ii-4) + :roles (list (list :player player-1 + :instance-of r-type-1 + :start-revision rev-2) + (list :player player-2 + :item-identifiers (list ii-2) + :instance-of r-type-2 + :start-revision rev-2))))) + (setf *TM-REVISION* rev-3) + (is (eql (d::merge-constructs type-1 type-2 :revision rev-3) type-1)) + (is (= (length (d::versions assoc-3)) 2)) + (is (= (length (d::versions assoc-4)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-1) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-3))) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-2) + (= (d::end-revision vi) rev-3))) + (d::versions assoc-4))) + (is (= (length (roles assoc-3)) 2)) + (is (= (length (item-identifiers (first (roles assoc-3)))) 1)) + (is (= (length (item-identifiers (second (roles assoc-3)))) 1)) + (is (or (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-1") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-2")) + (and (string= (uri (first (item-identifiers + (first (roles assoc-3))))) + "ii-2") + (string= (uri (first (item-identifiers + (second (roles assoc-3))))) + "ii-1"))))))))) + + + + + + +;;TODO: merge topics/associations caused by a merge of their characteristics +;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified +;; by the same reifier @@ -3108,4 +3521,9 @@ (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC) (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC) (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-2) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-3) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6) ) \ No newline at end of file

1 0

[isidorus-cvs] r285 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Apr '10

22 Apr '10

Author: lgiessmann Date: Thu Apr 22 06:51:39 2010 New Revision: 285 Log: new-datamodel: adapted the "mark-as-deleted" and "marked-as-deleted-p" methods to the new datamodel; added some unit-tests for mergeing topics Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Thu Apr 22 06:51:39 2010 @@ -7,7 +7,6 @@ ;;+----------------------------------------------------------------------------- -;-*- standard-indent:2; tab-width:2; indent-tabs-mode:nil -*- (in-package :datamodel) (defun get-all-revisions () @@ -36,19 +35,28 @@ (sort revision-set #'<))) -(defun find-associations-for-topic (top) - "find all associations of this topic" +(defun find-all-associations-for-topic (top &key (revision *TM-REVISION*)) + "Finds all associations for a topic." + (remove-duplicates + (map 'list #'(lambda(role) + (parent role :revision revision)) + (player-in-roles top :revision revision)))) + + +(defun find-associations-for-topic (top &key (revision *TM-REVISION*)) + "Finds all associations of this topic except type-instance-associations." (let ((type-instance-topic (d:identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "http://psi.topicmaps.org/iso13250/model/type-instance")))) - (remove - type-instance-topic - (remove-duplicates - (map 'list #'parent (player-in-roles top))) - :key #'instance-of))) + (remove-if + #'(lambda(assoc) + (when (eql (instance-of assoc :revision revision) + type-instance-topic) + t)) + (find-all-associations-for-topic top :revision revision)))) (defgeneric find-referenced-topics (construct) @@ -208,53 +216,9 @@ 'unique-id unique-id)) -;(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")) - -;(defmethod mark-as-deleted ((construct TopicMapConstructC) &key source-locator revision) -; "Mark a topic as deleted if it comes from the source indicated by -;source-locator" -; (declare (ignorable source-locator)) -; (let -; ((last-version ;the last active version -; (find 0 (versions construct) :key #'end-revision))) -; (when last-version -; (setf (end-revision last-version) revision)))) -; -;(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision) -; "Mark an association and its roles as deleted" -; (mapc (lambda (role) (mark-as-deleted role :revision revision :source-locator source-locator)) -; (roles ass)) -; (call-next-method)) -; -;(defmethod mark-as-deleted :around ((top TopicC) &key source-locator revision) -; "Mark a topic as deleted if it comes from the source indicated by -;source-locator" -; ;;Part 1b, 1.4.3.3.1: -; ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F -; ;; * Let SI be the value of TopicSI element in ATOM entry E -; ;; * feed F contains E -; ;; * entry E references topic fragment TF -; ;; * Let LTM be the local topic map -; ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI -; ;; * For all names, occurrences and associations in which T plays a role, TMC -; ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC -; ;; * Merge in the fragment TF using SP as the base all generated source locators. -; -; (when -; (some (lambda (psi) (string-starts-with (uri psi) source-locator)) (psis top)) -; (mapc (lambda (name) (mark-as-deleted name :revision revision :source-locator source-locator)) -; (names top)) -; (mapc (lambda (occ) (mark-as-deleted occ :revision revision :source-locator source-locator)) -; (occurrences top)) -; (mapc (lambda (ass) (mark-as-deleted ass :revision revision :source-locator source-locator)) -; (find-associations-for-topic top)) -; (call-next-method))) - (defgeneric add-source-locator (construct &key source-locator revision) (:documentation "adds an item identifier to a given construct based on the source -locator and an internally generated id (ideally a uuid)")) + locator and an internally generated id (ideally a uuid)")) (defmethod add-source-locator ((construct ReifiableConstructC) &key source-locator revision) (declare (ignorable revision)) 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 22 06:51:39 2010 @@ -839,6 +839,15 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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")) + + +(defgeneric marked-as-deleted-p (construct) + (:documentation "Returns t if the construct was marked-as-deleted.")) + + (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 @@ -875,11 +884,6 @@ 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")) - - (defgeneric find-oldest-construct (construct-1 construct-2) (:documentation "Returns the construct which owns the oldes version info. If a construct is not a versioned construct the oldest @@ -1089,14 +1093,11 @@ :versioned-construct construct)))))))) -(defgeneric marked-as-deleted-p (construct) - (:documentation "Returns t if the construct was marked-as-deleted.") - (:method ((construct VersionedConstructC)) - (if (find-if #'(lambda(vi) +(defmethod marked-as-deleted-p ((construct VersionedConstructC)) + (unless (find-if #'(lambda(vi) (= (end-revision vi) 0)) (versions construct)) - nil - t))) + t)) (defmethod mark-as-deleted ((construct VersionedConstructC) @@ -1107,7 +1108,7 @@ (find 0 (versions construct) :key #'end-revision))) (when last-version (setf (end-revision last-version) revision)))) - + ;;; TopicMapconstructC (defgeneric strictly-equivalent-constructs (construct-1 construct-2 @@ -1146,6 +1147,27 @@ ;;; PointerC +(defmethod mark-as-deleted ((construct PointerC) &key source-locator revision) + "Marks the last active relation between a pointer and its parent construct + as deleted." + (declare (ignorable source-locator)) + (let ((owner (identified-construct construct :revision 0))) + (when owner + (cond ((typep construct 'PersistentIdC) + (delete-psi owner construct :revision revision)) + ((typep construct 'SubjectLocatorC) + (delete-locator owner construct :revision revision)) + ((typep construct 'ItemIdentifierC) + (delete-item-identifier owner construct :revision revision)) + ((typep construct 'TopicIdentificationC) + (delete-topic-identifier owner construct :revision revision)))))) + + +(defmethod marked-as-deleted-p ((construct PointerC)) + (unless (identified-construct construct :revision 0) + t)) + + (defmethod find-oldest-construct ((construct-1 PointerC) (construct-2 PointerC)) (let ((vi-1 (find-version-info (slot-p construct-1 'identified-construct))) (vi-2 (find-version-info (slot-p construct-2 'identified-construct)))) @@ -1371,6 +1393,44 @@ ;;; TopicC +(defmethod mark-as-deleted :around ((top TopicC) + &key (source-locator nil sl-provided-p) + revision) + "Mark a topic as deleted if it comes from the source indicated by + source-locator" + ;;Part 1b, 1.4.3.3.1: + ;; Let SP be the value of the ServerSourceLocatorPrefix element in the ATOM feed F + ;; * Let SI be the value of TopicSI element in ATOM entry E + ;; * feed F contains E) + ;; * entry E references topic fragment TF + ;; * Let LTM be the local topic map + ;; * Let T be the topic in LTM that has a subjectidentifier that matches SI + ;; * For all names, occurrences and associations in which T plays a role, TMC + ;; * Delete all SrcLocators of TMC that begin with SP. If the count of srclocators on TMC = 0 then delete TMC + ;; * Merge in the fragment TF using SP as the base all generated source locators. + (when (or (and (not source-locator) sl-provided-p) + (and sl-provided-p + (some (lambda (psi) (string-starts-with (uri psi) source-locator)) + (psis top :revision 0)))) + (unless sl-provided-p + (mapc (lambda(psi)(mark-as-deleted psi :revision revision + :source-locator source-locator)) + (psis top :revision 0))) + (mapc (lambda(sl)(mark-as-deleted sl :revision revision + :source-locator source-locator)) + (locators top :revision 0)) + (mapc (lambda (name) (mark-as-deleted name :revision revision + :source-locator source-locator)) + (names top :revision 0)) + (mapc (lambda (occ) (mark-as-deleted occ :revision revision + :source-locator source-locator)) + (occurrences top :revision 0)) + (mapc (lambda (ass) (mark-as-deleted ass :revision revision + :source-locator source-locator)) + (find-all-associations-for-topic top :revision 0)) + (call-next-method))) + + (defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -2022,6 +2082,20 @@ ;;; CharacteristicC +(defmethod mark-as-deleted ((construct CharacteristicC) &key source-locator revision) + "Marks the last active relation between a characteristic and its parent topic + as deleted." + (declare (ignorable source-locator)) + (let ((owner (parent construct :revision 0))) + (when owner + (delete-characteristic owner construct :revision revision)))) + + +(defmethod marked-as-deleted-p ((construct CharacteristicC)) + (unless (parent construct :revision 0) + t)) + + (defmethod find-self-or-equal ((construct CharacteristicC) (parent-construct TopicC) &key (revision *TM-REVISION*)) @@ -2405,6 +2479,14 @@ ;;; AssociationC +(defmethod mark-as-deleted :around ((ass AssociationC) &key source-locator revision) + "Marks an association and its roles as deleted" + (mapc (lambda (role) + (mark-as-deleted role :revision revision :source-locator source-locator)) + (roles ass :revision 0)) + (call-next-method)) + + (defmethod equivalent-constructs ((construct-1 AssociationC) (construct-2 AssociationC) &key (revision *TM-REVISION*)) @@ -2527,6 +2609,20 @@ ;;; RoleC +(defmethod mark-as-deleted ((construct RoleC) &key source-locator revision) + "Marks the last active relation between a role and its parent association + as deleted." + (declare (ignorable source-locator)) + (let ((owner (parent construct :revision 0))) + (when owner + (delete-role owner construct :revision revision)))) + + +(defmethod marked-as-deleted-p ((construct RoleC)) + (unless (parent construct :revision 0) + t)) + + (defmethod find-self-or-equal ((construct RoleC) (parent-construct AssociationC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -2771,6 +2867,15 @@ ;;; ReifiableConstructC +(defmethod mark-as-deleted :around ((construct ReifiableConstructC) + &key source-locator revision) + "Marks all item-identifiers of a given reifiable-construct as deleted." + (declare (ignorable source-locator)) + (call-next-method) + (dolist (ii (item-identifiers construct :revision 0)) + (delete-item-identifier construct ii :revision revision))) + + (defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (declare (integer revision)) @@ -3739,7 +3844,7 @@ (declare (integer revision)) (let ((occs-to-move (occurrences source :revision revision))) (dolist (occ occs-to-move) - (delete-occurrence occ source :revision revision) + (delete-occurrence source occ :revision revision) (let ((equivalent-occ (find-if #'(lambda (destination-occ) (when @@ -3847,7 +3952,7 @@ (move-referenced-constructs newer-topic older-topic :revision revision) (move-reified-construct newer-topic older-topic :revision revision) (merge-changed-constructs older-topic :revision revision) - (mark-as-deleted newer-topic :revision revision) + (mark-as-deleted newer-topic :revision revision :source-locator nil) (when (exist-in-revision-history-? newer-topic) (delete-construct newer-topic)) older-topic)))) 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 Thu Apr 22 06:51:39 2010 @@ -81,10 +81,11 @@ :test-find-oldest-construct :test-move-referenced-constructs-ReifiableConstructC :test-move-referenced-constructs-NameC - :test-move-referenced-constructs-TopicC)) + :test-merge-constructs-TopicC-1)) ;;TODO: test merge-constructs +;;TODO: test mark-as-deleted @@ -2932,13 +2933,15 @@ (variants name-2 :revision rev-2))))))))) -(test test-move-referenced-constructs-TopicC () +(test test-merge-constructs-TopicC-1 () "Tests the generic move-referenced-constructs corresponding to TopicC." (with-fixture with-empty-db (*db-dir*) (let ((rev-1 100) - (rev-2 200)) + (rev-2 200) + (rev-3 300)) (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) @@ -2956,7 +2959,7 @@ :charvalue "var-1" :themes (list theme-1))) (variant-2 (make-construct 'VariantC - :start-revision rev-1 + :start-revision rev-2 :charvalue "var-2" :themes (list theme-2))) (variant-3 (make-construct 'VariantC @@ -2973,7 +2976,8 @@ :charvalue "occ-2" :instance-of type-2)) (occ-3 (make-construct 'OccurrenceC - :start-revision rev-1 + :start-revision rev-2 + :item-identifiers (list ii-3) :charvalue "occ-1" :instance-of type-1 :themes (list theme-1)))) @@ -2981,8 +2985,68 @@ :start-revision rev-1 :charvalue "name-1" :instance-of type-1)) - ) - )))))) + (name-2 (make-construct 'NameC + :start-revision rev-2 + :charvalue "name-2" + :instance-of type-1 + :variants (list variant-1 variant-2))) + (name-3 (make-construct 'NameC + :start-revision rev-1 + :charvalue "name-1" + :instance-of type-1 + :variants (list variant-3)))) + (let ((top-1 (make-construct 'TopicC + :start-revision rev-1 + :topic-identifiers (list tid-1) + :item-identifiers (list ii-1) + :locators (list sl-1) + :psis (list psi-1) + :names (list name-1 name-2) + :occurrences (list occ-1 occ-2))) + (top-2 (make-construct 'TopicC + :start-revision rev-2 + :topic-identifiers (list tid-2) + :item-identifiers (list ii-2) + :locators (list sl-2) + :psis (list psi-2) + :names (list name-3) + :occurrences (list occ-3)))) + (setf *TM-REVISION* rev-3) + (let ((top (d::merge-constructs top-1 top-2 :revision rev-3))) + (is (eql top top-1)) + (is-true (d::marked-as-deleted-p top-2)) + (is-false (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + (setf *TM-REVISION* rev-2) + (is (= (length (append (psis top-2) (item-identifiers top-2) + (locators top-2) (topic-identifiers top-2) + (names top-2) (occurrences top-2))) + 6)) + (setf *TM-REVISION* rev-3) + (is-false (set-exclusive-or (list ii-1 ii-2) + (item-identifiers top-1))) + (is-false (set-exclusive-or (list sl-1 sl-2) (locators top-1))) + (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1))) + (is-false (set-exclusive-or (list tid-1 tid-2) + (topic-identifiers top-1))) + (is-false (set-exclusive-or (list psi-1) + (psis top-1 :revision rev-2))) + (is-false (set-exclusive-or (list name-1 name-2) + (names top-1))) + (is-false (set-exclusive-or (variants name-1) + (list variant-3))) + (is-false (variants name-3)) + (is-false (set-exclusive-or (occurrences top-1) + (list occ-1 occ-2))) + (is-false (set-exclusive-or (item-identifiers occ-1) + (list ii-3))) + (is-false (item-identifiers occ-3)) + (is-true (d::marked-as-deleted-p name-3)) + (is-true (d::marked-as-deleted-p occ-3)))))))))) + + + (defun run-datamodel-tests() @@ -3043,5 +3107,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) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-1) ) \ No newline at end of file

1 0

[isidorus-cvs] r284 - in trunk/src: json model
by Lukas Giessmann 18 Apr '10

18 Apr '10

Author: lgiessmann Date: Sun Apr 18 08:50:40 2010 New Revision: 284 Log: json+datamodel: modified the procedure of adding constructs to a new version-history --> currently a construct gets a new version-info if it was marked-as-deleted before or it has new item-identifiers Modified: trunk/src/json/json_importer.lisp trunk/src/model/datamodel.lisp Modified: trunk/src/json/json_importer.lisp ============================================================================== --- trunk/src/json/json_importer.lisp (original) +++ trunk/src/json/json_importer.lisp Sun Apr 18 08:50:40 2010 @@ -38,7 +38,7 @@ (first psi-uris))))) (elephant:ensure-transaction (:txn-nosync nil) (xml-importer:with-tm (rev xtm-id (first (getf fragment-values :tm-ids))) - (loop for topicStub-values in (append topicStubs-values (list topic-values)) + (loop for topicStub-values in topicStubs-values do (json-to-stub topicStub-values rev :tm xml-importer::tm :xtm-id xtm-id)) (json-merge-topic topic-values rev :tm xml-importer::tm :xtm-id xtm-id) (loop for association-values in associations-values @@ -103,31 +103,29 @@ elements from the json-decoded-list" (when json-decoded-list (elephant:ensure-transaction (:txn-nosync t) - (let ((top - (d:get-item-by-id - (getf json-decoded-list :id) - :revision start-revision - :xtm-id xtm-id))) +; (let ((top +; (d:get-item-by-id +; (getf json-decoded-list :id) +; :revision start-revision +; :xtm-id xtm-id))) + (let ((top (json-to-stub json-decoded-list start-revision + :tm tm :xtm-id xtm-id))) (declare (list json-decoded-list)) (declare (integer start-revision)) (declare (TopicMapC tm)) (unless top (error "topic ~a could not be found" (getf json-decoded-list :id))) - (let ((instanceof-topics (remove-duplicates (map 'list #'psis-to-topic (getf json-decoded-list :instanceOfs))))) - (loop for name-values in (getf json-decoded-list :names) do (json-to-name name-values top start-revision)) - (loop for occurrence-values in (getf json-decoded-list :occurrences) do (json-to-occurrence occurrence-values top start-revision)) (dolist (instanceOf-top instanceof-topics) (json-create-instanceOf-association instanceOf-top top start-revision :tm tm)) -; (add-to-topicmap tm top) ; will be done in "json-to-stub" top))))) @@ -246,10 +244,8 @@ (psis-to-topic (getf json-decoded-list :type)))) (declare (list json-decoded-list)) (declare (TopicC top)) - (unless namevalue (error "A name must have exactly one namevalue")) - (let ((name (make-construct 'NameC :start-revision start-revision :topic top Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Apr 18 08:50:40 2010 @@ -495,13 +495,14 @@ (existing-construct (first (find-all-equivalent new-construct)))) (if existing-construct (progn - ;change over new item identifiers to the old construct - (when (copy-item-identifiers - new-construct existing-construct) - ;an existing construct other than a topic (which is handled - ;separatedly below) has changed only if it has received a new - ;item identifier - (add-to-version-history existing-construct :start-revision start-revision)) + ;change over new item identifiers to the old construct + ;the version-history is also changed if the construct was + ;marked-as-deleted before + (when (or (copy-item-identifiers new-construct existing-construct) + (not (find-most-recent-revision existing-construct))) + (add-to-version-history existing-construct + :start-revision start-revision)) + (delete-construct new-construct) existing-construct) (progn

1 0

[isidorus-cvs] r283 - trunk/src/ajax/javascripts
by Lukas Giessmann 16 Apr '10

16 Apr '10

Author: lgiessmann Date: Fri Apr 16 16:08:53 2010 New Revision: 283 Log: ui: after deleting names all variants of the deleted name are removed Modified: trunk/src/ajax/javascripts/datamodel.js Modified: trunk/src/ajax/javascripts/datamodel.js ============================================================================== --- trunk/src/ajax/javascripts/datamodel.js (original) +++ trunk/src/ajax/javascripts/datamodel.js Fri Apr 16 16:08:53 2010 @@ -1453,7 +1453,7 @@ if(contents){ var myself = this; this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Name", myself); + makeRemoveObject("Name", myself); }, "delete Name")}); } } @@ -1858,7 +1858,7 @@ if(contents){ var myself = this; this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Occurrence", myself); + makeRemoveObject("Occurrence", myself); }, "delete Occurrence")}); } } @@ -2276,7 +2276,7 @@ if(content){ var myself = this; this.__table__.insert({"bottom" : makeRemoveLink(function(event){ - makeDeleteObject("Topic", myself); + makeRemoveObject("Topic", myself); }, "delete Topic")});} }catch(err){ alert("From TopciC(): " + err); @@ -4351,14 +4351,14 @@ // --- calls the given object's mark-as-deleted service -function makeDeleteObject(type, objectToDelete){ +function makeRemoveObject(type, objectToDelete){ if(type !== "Occurrence" && type !== "Name" && type !== "Variant" && type !== "Topic" && type !== "Association"){ - throw "From makeDeleteObject(): type must be: \"Occurrence\" || \"Name\" " + + throw "From makeRemoveObject(): type must be: \"Occurrence\" || \"Name\" " + "|| \"Variant\" || \"Topic\" || \"Association\" but is " + type; } if (!objectToDelete){ - throw "From makeDeleteObject(): objectToDelete must be set"; + throw "From makeRemoveObject(): objectToDelete must be set"; } var parentTopic = "null"; @@ -4415,7 +4415,13 @@ } else { if(type === "Occurrence"){ objectToDelete.__value__.setValue(""); } - else { objectToDelete.__value__.__frames__[0].__content__.setValue(""); } + else { + objectToDelete.__value__.__frames__[0].__content__.setValue(""); + var vars = objectToDelete.__variants__; + objectToDelete.__variants__ = new VariantContainerC(null, objectToDelete); + vars.append(objectToDelete.__variants__.getFrame()); + vars.remove(); + } var ii = objectToDelete.__itemIdentity__; objectToDelete.__itemIdentity__ = new ItemIdentityC(null, objectToDelete); ii.append(objectToDelete.__itemIdentity__.getFrame());

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs April 2010