Author: lgiessmann Date: Fri Nov 20 05:41:32 2009 New Revision: 144 Log: added some unit-tests for the "reification"-functions; fixed some problems; currently there is still a problem with the versioning of constructs that existed more than one revision and were not merged at the initial version. Added: trunk/src/unit_tests/reification_test.lisp Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Fri Nov 20 05:41:32 2009 @@ -143,7 +143,9 @@ (:file "rdf_importer_test" :depends-on ("fixtures")) (:file "rdf_exporter_test" - :depends-on ("fixtures"))) + :depends-on ("fixtures")) + (:file "reification_test" + :depends-on ("fixtures" "unittests-constants"))) :depends-on ("atom" "constants" "model" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Fri Nov 20 05:41:32 2009 @@ -621,80 +621,6 @@ (setf (slot-value construct 'reifier) topic) (setf (reified topic) construct))) -(defgeneric add-reifier (construct reifier-uri) - (:method ((construct ReifiableConstructC) reifier-uri) - (let ((err "From add-reifier(): ")) - (let ((item-identifier - (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) - (unless item-identifier - (error "~ano item-identifier could be found with the uri ~a" - err reifier-uri)) - (let ((reifier-topic (identified-construct item-identifier))) - (unless (typep reifier-topic 'TopicC) - (error "~anitem-identifier ~a must be bound to a topic, but is ~a" - err reifier-uri (type-of reifier-topic))) - (cond - ((and (not (reifier construct)) - (not (reified reifier-topic))) - (setf (reifier construct) reifier-topic) - (setf (reified reifier-topic) construct)) - ((and (not (reified reifier-topic)) - (reifier construct)) - (merge-reifier-topics (reifier construct) reifier-topic)) - ((and (not (reifier construct)) - (reified reifier-topic)) - (error "~a~a reifies already another object ~a" - err reifier-uri (reified reifier-topic))) - (t - (when (not (eql (reified reifier-topic) construct)) - (error "~a~a reifies already another object ~a" - err reifier-uri (reified reifier-topic))) - (merge-reifier-topics (reifier construct) reifier-topic)))))) - construct)) - -(defgeneric merge-reifier-topics (old-topic new-topic) - ;;the reifier topics are not only merged but also bound to the reified-construct - (:method ((old-topic TopicC) (new-topic TopicC)) - (unless (eql old-topic new-topic) - ;merges all identifiers - (move-identifiers old-topic new-topic) - (move-identifiers old-topic new-topic :what 'locators) - (move-identifiers old-topic new-topic :what 'psis) - (move-identifiers old-topic new-topic :what 'topic-identifiers) - ;merges all typed-object-associations - (dolist (typed-construct (used-as-type new-topic)) - (remove-association typed-construct 'instance-of new-topic) - (add-association typed-construct 'instance-of old-topic)) - ;merges all scope-object-associations - (dolist (scoped-construct (used-as-theme new-topic)) - (remove-association scoped-construct 'theme new-topic) - (add-association scoped-construct 'theme old-topic)) - (dolist (tm (in-topicmaps new-topic)) - (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it - (dolist (a-role (player-in-roles new-topic)) - (remove-association a-role 'player new-topic) - (add-association a-role 'player old-topic)) - ;merges all names - (dolist (name (names new-topic)) - (remove-association name 'topic new-topic) - (add-association name 'topic old-topic)) - ;merges all occurrences - (dolist (occurrence (occurrences new-topic)) - (remove-association occurrence 'topic new-topic) - (add-association occurrence 'topic old-topic)) - ;merges all version-infos - (let ((versions-to-move - (loop for vrs in (versions new-topic) - when (not (find-if #'(lambda(x) - (and (= (start-revision x) (start-revision vrs)) - (= (end-revision x) (end-revision vrs)))) - (versions old-topic))) - collect vrs))) - (dolist (vrs versions-to-move) - (remove-association vrs 'versioned-construct new-topic) - (add-association vrs 'versioned-construct old-topic)))))) - - (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) @@ -1654,4 +1580,83 @@ (defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) (when (find-item-by-revision ass revision) - (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id))) \ No newline at end of file + (find (d:internal-id ass) (d:associations tm) :test #'= :key #'d:internal-id))) + +;;;;;;;;;;;;;;;;; +;; reification + +(defgeneric add-reifier (construct reifier-uri) + (:method ((construct ReifiableConstructC) reifier-uri) + (let ((err "From add-reifier(): ")) + (let ((item-identifier + (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) + (unless item-identifier + (error "~ano item-identifier could be found with the uri ~a" + err reifier-uri)) + (let ((reifier-topic (identified-construct item-identifier))) + (unless (typep reifier-topic 'TopicC) + (error "~anitem-identifier ~a must be bound to a topic, but is ~a" + err reifier-uri (type-of reifier-topic))) + (cond + ((and (not (reifier construct)) + (not (reified reifier-topic))) + (setf (reifier construct) reifier-topic)) + ((and (not (reified reifier-topic)) + (reifier construct)) + (merge-reifier-topics (reifier construct) reifier-topic)) + ((and (not (reifier construct)) + (reified reifier-topic)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + (t + (when (not (eql (reified reifier-topic) construct)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + (merge-reifier-topics (reifier construct) reifier-topic)))))) + construct)) + +(defgeneric merge-reifier-topics (old-topic new-topic) + ;;the reifier topics are not only merged but also bound to the reified-construct + (:method ((old-topic TopicC) (new-topic TopicC)) + (unless (eql old-topic new-topic) + ;merges all identifiers + (move-identifiers old-topic new-topic) + (move-identifiers old-topic new-topic :what 'locators) + (move-identifiers old-topic new-topic :what 'psis) + (move-identifiers old-topic new-topic :what 'topic-identifiers) + ;merges all typed-object-associations + (dolist (typed-construct (used-as-type new-topic)) + (remove-association typed-construct 'instance-of new-topic) + (add-association typed-construct 'instance-of old-topic)) + ;merges all scope-object-associations + (dolist (scoped-construct (used-as-theme new-topic)) + (remove-association scoped-construct 'themes new-topic) + (add-association scoped-construct 'themes old-topic)) + (dolist (tm (in-topicmaps new-topic)) + (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it + (dolist (a-role (player-in-roles new-topic)) + (remove-association a-role 'player new-topic) + (add-association a-role 'player old-topic)) + ;merges all names + (dolist (name (names new-topic)) + (remove-association name 'topic new-topic) + (add-association name 'topic old-topic)) + ;merges all occurrences + (dolist (occurrence (occurrences new-topic)) + (remove-association occurrence 'topic new-topic) + (add-association occurrence 'topic old-topic)) + ;merges all version-infos + (let ((versions-to-move + (loop for vrs in (versions new-topic) + when (not (find-if #'(lambda(x) + (and (= (start-revision x) (start-revision vrs)) + (= (end-revision x) (end-revision vrs)))) + (versions old-topic))) + collect vrs))) + (dolist (vrs versions-to-move) + (remove-association vrs 'versioned-construct new-topic) + (add-association vrs 'versioned-construct old-topic))) + (delete-construct new-topic)) + ;TODO: order/repair all version-infos of the topic itself and add all new + ; versions to the original existing objects of the topic + old-topic)) \ No newline at end of file Added: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/reification_test.lisp Fri Nov 20 05:41:32 2009 @@ -0,0 +1,178 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :reification-test + (:use + :common-lisp + :datamodel + :it.bese.FiveAM + :unittests-constants + :fixtures) + (:export + :reification-test + :run-reification-tests + :test-merge-reifier-topics)) + + +(in-package :reification-test) + + +(def-suite reification-test + :description "tests various functions of the reification functions") + +(in-suite reification-test) + + +(test test-merge-reifier-topics + "Tests the function merge-reifier-topics." + (let ((db-dir "data_base") + (revision-1 100) + (revision-2 200)) + (clean-out-db db-dir) + (elephant:open-store (xml-importer:get-store-spec db-dir)) + (let ((ii-1-1 (make-instance 'ItemIdentifierC + :uri "ii-1-1" + :start-revision revision-1)) + (ii-1-2 (make-instance 'ItemIdentifierC + :uri "ii-1-2" + :start-revision revision-1)) + (ii-2-1 (make-instance 'ItemIdentifierC + :uri "ii-2-1" + :start-revision revision-2)) + (ii-2-2 (make-instance 'ItemIdentifierC + :uri "ii-2-2" + :start-revision revision-2)) + (psi-1-1 (make-instance 'PersistentIdC + :uri "psi-1-1" + :start-revision revision-1)) + (psi-1-2 (make-instance 'PersistentIdC + :uri "psi-1-2" + :start-revision revision-1)) + (locator-2-1 (make-instance 'SubjectLocatorC + :uri "locator-2-1" + :start-revision revision-2)) + (xtm-id-1 "xtm-id-1") + (xtm-id-2 "xtm-id-2") + (topic-id-1 "topic-id-1") + (topic-id-2 "topic-id-1")) ;should no be merged, since the xtm-id differs + (let ((topic-1 (make-construct 'TopicC + :item-identifiers (list ii-1-1 ii-1-2) + :locators nil + :psis (list psi-1-1 psi-1-2) + :topicid topic-id-1 + :xtm-id xtm-id-1 + :start-revision revision-1)) + (topic-2 (make-construct 'TopicC + :item-identifiers (list ii-2-1 ii-2-2) + :locators (list locator-2-1) + :psis nil + :topicid topic-id-2 + :xtm-id xtm-id-2 + :start-revision revision-2)) + (scope-1 (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-scope-1" + :start-revision revision-1)) + :topicid "scope-1" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (scope-2 (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-scope-2" + :start-revision revision-1)) + :topicid "scope-2" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (name-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-name-type" + :start-revision revision-1)) + :topicid "name-type" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (occurrence-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-occurrence-type" + :start-revision revision-1)) + :topicid "occurrence-type" + :xtm-id xtm-id-1 + :start-revision revision-1))) + (let ((name-1-1 (make-construct 'NameC + :item-identifiers nil + :topic topic-1 + :themes (list scope-1) + :instance-of name-type + :charvalue "name-1-1" + :start-revision revision-1)) + (name-2-1 (make-construct 'NameC + :item-identifiers (list (make-instance 'ItemIdentifierC + :uri "name-2-1-ii-1" + :start-revision revision-1)) + :topic topic-2 + :themes (list scope-2) + :instance-of nil + :charvalue "name-2-1" + :start-revision revision-2)) + (occurrence-2-1 (make-construct 'OccurrenceC + :item-identifiers (list (make-instance 'ItemIdentifierC + :uri "occurrence-1-1-ii-1" + :start-revision revision-1)) + :topic topic-2 + :themes (list scope-1 scope-2) + :instance-of occurrence-type + :charvalue "occurrence-2-1" + :datatype "datatype" + :start-revision revision-2)) + (occurrence-2-2 (make-construct 'OccurrenceC + :item-identifiers nil + :topic topic-2 + :themes nil + :instance-of occurrence-type + :charvalue "occurrence-2-2" + :datatype "datatype" + :start-revision revision-2)) + (test-name (make-construct 'NameC + :item-identifiers nil + :topic scope-2 + :themes (list scope-1 topic-2) + :instance-of topic-2 + :charvalue "test-name" + :start-revision revision-2))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 6)) + (datamodel::merge-reifier-topics topic-1 topic-2) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2) + (item-identifiers topic-1))) + (length (list ii-1-1 ii-1-2 ii-2-1 ii-2-2)))) + (is (= (length (union (list psi-1-1 psi-1-2) + (psis topic-1))) + (length (list psi-1-1 psi-1-2)))) + (is (= (length (union (list locator-2-1) + (locators topic-1))) + (length (list locator-2-1)))) + (is (= (length (union (names topic-1) + (list name-1-1 name-2-1))) + (length (list name-1-1 name-2-1)))) + (is (= (length (union (occurrences topic-1) + (list occurrence-2-1 occurrence-2-2))) + (length (list occurrence-2-1 occurrence-2-2)))) + (is (= (length (union (d:used-as-type topic-1) + (list test-name))) + (length (list test-name)))) + (is (= (length (union (d:used-as-theme topic-1) + (list test-name))) + (length (list test-name)))) + ;;TODO: roleplayer, topicmap + ;;TODO: check all objects and their version-infos + (elephant:close-store)))))) + + +(defun run-reification-tests () + (it.bese.fiveam:run! 'test-merge-reifier-topics) + ) \ No newline at end of file