From lgiessmann at common-lisp.net Tue Nov 17 11:21:41 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 17 Nov 2009 06:21:41 -0500 Subject: [isidorus-cvs] r142 - trunk/src/model Message-ID: Author: lgiessmann Date: Tue Nov 17 06:21:40 2009 New Revision: 142 Log: added the generic function add-reifier which adds a reifier to a reifiable object. currently this function does not merge reifier-topics Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 17 06:21:40 2009 @@ -103,6 +103,7 @@ :create-latest-fragment-of-topic :reified :reifier + :add-reifier :*current-xtm* ;; special variables :*TM-REVISION* @@ -620,6 +621,54 @@ (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 "~aitem-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 topics + t) + ((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 both topics or throw an error + t))))) + construct)) + + +(defgeneric merge-reifier-topics (old-topic new-topic) + (:method ((old-topic TopicC) (new-topic TopicC)) + ;move all item-identifiers to the new topic ;check if they are already existing + ;move all subject-locators to the new topic ;check if they are already existing + ;move all subject-identifiers to the new topic ;check if they are already existing + ;move all names to the new topic ;check if they are already existing + ;move all occurrences to the new topic ;check if they are already existing + ;check all objects where the topic is the type of + ;check all roles where the topic is a player of + ;check all objects where the topic is a scope of + (format t "~a~a" old-topic new-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))) From lgiessmann at common-lisp.net Tue Nov 17 19:02:14 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 17 Nov 2009 14:02:14 -0500 Subject: [isidorus-cvs] r143 - trunk/src/model Message-ID: Author: lgiessmann Date: Tue Nov 17 14:02:13 2009 New Revision: 143 Log: added a function to merge reifier-topics. unit-tests are currently missing. the add-refier function can be used by all importers in the "merge-topic"-functions. Modified: trunk/src/model/datamodel.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 17 14:02:13 2009 @@ -631,7 +631,7 @@ err reifier-uri)) (let ((reifier-topic (identified-construct item-identifier))) (unless (typep reifier-topic 'TopicC) - (error "~aitem-identifier ~a must be bound to a topic, but is ~a" + (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)) @@ -640,8 +640,7 @@ (setf (reified reifier-topic) construct)) ((and (not (reified reifier-topic)) (reifier construct)) - ;merge topics - t) + (merge-reifier-topics (reifier construct) reifier-topic)) ((and (not (reifier construct)) (reified reifier-topic)) (error "~a~a reifies already another object ~a" @@ -650,23 +649,50 @@ (when (not (eql (reified reifier-topic) construct)) (error "~a~a reifies already another object ~a" err reifier-uri (reified reifier-topic))) - ;merge both topics or throw an error - t))))) + (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)) - ;move all item-identifiers to the new topic ;check if they are already existing - ;move all subject-locators to the new topic ;check if they are already existing - ;move all subject-identifiers to the new topic ;check if they are already existing - ;move all names to the new topic ;check if they are already existing - ;move all occurrences to the new topic ;check if they are already existing - ;check all objects where the topic is the type of - ;check all roles where the topic is a player of - ;check all objects where the topic is a scope of - (format t "~a~a" old-topic new-topic) - )) + (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) @@ -1050,6 +1076,39 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) +(defun move-identifiers(destination-topic source-topic &key (what 'item-identifiers)) + "Moves all identifiers from the source-topic to the destination topic." + (declare (TopicC destination-topic source-topic)) + (let ((all-source-identifiers + (cond + ((eql what 'item-identifiers) + (item-identifiers source-topic)) + ((eql what 'locators) + (locators source-topic)) + (t + (psis source-topic)))) + (all-destination-identifiers + (cond + ((eql what 'item-identifiers) + (item-identifiers destination-topic)) + ((eql what 'locators) + (locators destination-topic)) + ((eql what 'psis) + (psis destination-topic)) + ((eql what 'topic-identifiers) + (topic-identifiers destination-topic))))) + (let ((identifiers-to-move + (loop for id in all-source-identifiers + when (not (find-if #'(lambda(x) + (if (eql what 'topic-identifiers) + (string= (xtm-id x) (xtm-id id)) + (string= (uri x) (uri id)))) + all-destination-identifiers)) + collect id))) + (dolist (item identifiers-to-move) + (remove-association source-topic what item) + (add-association destination-topic what item))))) + (defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis)) From lgiessmann at common-lisp.net Fri Nov 20 10:41:33 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Fri, 20 Nov 2009 05:41:33 -0500 Subject: [isidorus-cvs] r144 - in trunk/src: . model unit_tests Message-ID: 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 From lgiessmann at common-lisp.net Sun Nov 22 18:16:49 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 22 Nov 2009 13:16:49 -0500 Subject: [isidorus-cvs] r145 - in trunk/src: model unit_tests xml/xtm Message-ID: Author: lgiessmann Date: Sun Nov 22 13:16:47 2009 New Revision: 145 Log: added the support for reification in the xtm 2.0 importer Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Nov 22 13:16:47 2009 @@ -1615,6 +1615,7 @@ (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)) @@ -1632,8 +1633,10 @@ (dolist (scoped-construct (used-as-theme new-topic)) (remove-association scoped-construct 'themes new-topic) (add-association scoped-construct 'themes old-topic)) + ;merges all topic-maps (dolist (tm (in-topicmaps new-topic)) (add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it + ;merges all role-players (dolist (a-role (player-in-roles new-topic)) (remove-association a-role 'player new-topic) (add-association a-role 'player old-topic)) Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Sun Nov 22 13:16:47 2009 @@ -96,6 +96,20 @@ :topicid "name-type" :xtm-id xtm-id-1 :start-revision revision-1)) + (assoc-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-assoc-type" + :start-revision revision-1)) + :topicid "assoc-type" + :xtm-id xtm-id-1 + :start-revision revision-1)) + (role-type (make-construct 'TopicC + :psis (list (make-instance 'PersistentIdC + :uri "psi-role-type" + :start-revision revision-1)) + :topicid "assoc-type" + :xtm-id xtm-id-1 + :start-revision revision-1)) (occurrence-type (make-construct 'TopicC :psis (list (make-instance 'PersistentIdC :uri "psi-occurrence-type" @@ -143,10 +157,29 @@ :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)) + :start-revision revision-2)) + (assoc (make-construct 'AssociationC + :item-identifiers nil + :instance-of assoc-type + :themes nil + :roles + (list + (list :instance-of role-type + :player topic-1 + :item-identifiers + (list (make-instance 'ItemIdentifierC + :uri "role-1" + :start-revision revision-1))) + (list :instance-of role-type + :player topic-2 + :item-identifiers + (list (make-instance 'ItemIdentifierC + :uri "role-2" + :start-revision revision-1)))) + :start-revision revision-1))) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 8)) (datamodel::merge-reifier-topics topic-1 topic-2) - (is (= (length (elephant:get-instances-by-class 'TopicC)) 5)) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) (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)))) @@ -168,11 +201,18 @@ (is (= (length (union (d:used-as-theme topic-1) (list test-name))) (length (list test-name)))) - ;;TODO: roleplayer, topicmap + (is (eql (player (first (roles assoc))) topic-1)) + (is (eql (player (second (roles assoc))) topic-1)) ;;TODO: check all objects and their version-infos (elephant:close-store)))))) +;;TODO: check xtm1.0 importer +;;TODO: check xtm2.0 importer +;;TODO: check rdf importer +;;TODO: check fragment exporter + + (defun run-reification-tests () (it.bese.fiveam:run! 'test-merge-reifier-topics) ) \ No newline at end of file Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sun Nov 22 13:16:47 2009 @@ -9,6 +9,17 @@ (in-package :xml-importer) +(defun set-reifier (reifiable-elem reifiable-construct) + "Sets the reifier-topic of the passed elem to the passed construct." + (declare (dom:element reifiable-elem)) + (declare (ReifiableConstructC reifiable-construct)) + (let ((reifier-uri (get-attribute reifiable-elem "reifier"))) + (when (and (stringp reifier-uri) + (> (length reifier-uri) 0)) + (add-reifier reifiable-construct reifier-uri)) + reifiable-construct)) + + (defun from-identifier-elem (classsymbol elem start-revision) "Generate an identifier object of type 'classsymbol' (a subclass of IdentifierC) from a given identifier element for a revision and return @@ -127,7 +138,7 @@ :themes themes))) (loop for variant-elem across (xpath-child-elems-by-qname name-elem *xtm2.0-ns* "variant") do (from-variant-elem variant-elem name start-revision :xtm-id xtm-id)) - name))) + (set-reifier name-elem name)))) (defun from-resourceX-elem (parent-elem) @@ -180,13 +191,14 @@ (unless variant-value (error "VariantC: one of resourceRef and resourceData must be set")) - (make-construct 'VariantC - :start-revision start-revision - :item-identifiers item-identifiers - :themes themes - :charvalue (getf variant-value :data) - :datatype (getf variant-value :type) - :name name))) + (let ((variant (make-construct 'VariantC + :start-revision start-revision + :item-identifiers item-identifiers + :themes themes + :charvalue (getf variant-value :data) + :datatype (getf variant-value :type) + :name name))) + (set-reifier variant-elem variant)))) (defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*)) @@ -211,14 +223,15 @@ (occurrence-value (from-resourceX-elem occ-elem))) (unless occurrence-value (error "OccurrenceC: one of resourceRef and resourceData must be set")) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes themes - :item-identifiers item-identifiers - :instance-of instance-of - :charvalue (getf occurrence-value :data) - :datatype (getf occurrence-value :type)))) + (let ((occurrence (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes themes + :item-identifiers item-identifiers + :instance-of instance-of + :charvalue (getf occurrence-value :data) + :datatype (getf occurrence-value :type)))) + (set-reifier occ-elem occurrence)))) @@ -322,7 +335,13 @@ (xpath-single-child-elem-by-qname role-elem *xtm2.0-ns* - "topicRef")) :xtm-id xtm-id))) + "topicRef")) :xtm-id xtm-id)) + (reifier-uri + (let ((value (get-attribute role-elem "reifier"))) + (if (and (stringp value) + (> (length value) 0)) + value + nil)))) ; (unless (and player instance-of) ; (error "Role in association not complete")) (unless player ;instance-of will be set later - if there is no one @@ -331,7 +350,10 @@ role-elem *xtm2.0-ns* "topicRef")))) - (list :instance-of instance-of :player player :item-identifiers item-identifiers)))) + (list :reifier-uri reifier-uri + :instance-of instance-of + :player player + :item-identifiers item-identifiers)))) (defun from-association-elem (assoc-elem start-revision @@ -339,7 +361,7 @@ tm (xtm-id *current-xtm*)) "Constructs an AssociationC object from an association element -association = element association { reifiable, type, scope?, role+ }" + association = element association { reifiable, type, scope?, role+ }" (declare (dom:element assoc-elem)) (declare (integer start-revision)) (declare (TopicMapC tm)) @@ -366,14 +388,25 @@ assoc-elem *xtm2.0-ns* "role")))) (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them - - (add-to-topicmap tm - (make-construct 'AssociationC - :start-revision start-revision - :item-identifiers item-identifiers - :instance-of instance-of - :themes themes - :roles roles))))) + (let ((assoc (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :item-identifiers item-identifiers + :instance-of instance-of + :themes themes + :roles roles)))) + (map 'list #'(lambda(assoc-role) + (map 'list #'(lambda(list-role) + (when (and (eql (instance-of assoc-role) + (getf list-role :instance-of)) + (eql (player assoc-role) + (getf list-role :player)) + (getf list-role :reifier-uri)) + (add-reifier assoc-role (getf list-role :reifier-uri)))) + roles)) + (roles assoc)) + (set-reifier assoc-elem assoc))))) From lgiessmann at common-lisp.net Sun Nov 22 20:11:49 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Sun, 22 Nov 2009 15:11:49 -0500 Subject: [isidorus-cvs] r146 - in trunk/src: model xml/xtm Message-ID: Author: lgiessmann Date: Sun Nov 22 15:11:48 2009 New Revision: 146 Log: added the support of reification in xtm1.0 Modified: trunk/src/model/datamodel.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Nov 22 15:11:48 2009 @@ -1585,34 +1585,36 @@ ;;;;;;;;;;;;;;;;; ;; reification -(defgeneric add-reifier (construct reifier-uri) - (:method ((construct ReifiableConstructC) reifier-uri) +(defgeneric add-reifier (construct reifier-uri reifier-must-exist) + (:method ((construct ReifiableConstructC) reifier-uri reifier-must-exist) (let ((err "From add-reifier(): ")) (let ((item-identifier - (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) + (elephant:get-instance-by-value 'ItemIdentifierC '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)) + (when reifier-must-exist + (error "~ano item-identifier could be found with the uri ~a" + err reifier-uri))) + (when item-identifier + (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))) - (merge-reifier-topics (reifier construct) 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)) Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Sun Nov 22 15:11:48 2009 @@ -9,6 +9,19 @@ (in-package :xml-importer) +(defun set-reifier-xtm1.0 (reifiable-elem reifiable-construct) + "Sets the reifier-topic of the passed elem to the passed construct." + (declare (dom:element reifiable-elem)) + (declare (ReifiableConstructC reifiable-construct)) + (let ((reifier-uri + (when (dom:get-attribute-node reifiable-elem "id") + (dom:node-value (dom:get-attribute-node reifiable-elem "id"))))) + (when (and (stringp reifier-uri) + (> (length reifier-uri) 0)) + (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) nil)) + reifiable-construct)) + + (defun get-topic-id-xtm1.0 (topic-elem) "returns the id attribute of a topic element" (declare (dom:element topic-elem)) @@ -77,6 +90,7 @@ :charvalue (getf variantName :data) :datatype (getf variantName :type) :name parent-name))) + (set-reifier-xtm1.0 variant-elem variant) (let ((inner-variants (map 'list #'(lambda(x) (from-variant-elem-xtm1.0 x variant start-revision :xtm-id xtm-id)) @@ -138,6 +152,7 @@ :topic top :charvalue baseNameString :themes themes))) + (set-reifier-xtm1.0 baseName-elem name) (map 'list #'(lambda(x) (from-variant-elem-xtm1.0 x name start-revision :xtm-id xtm-id)) (xpath-child-elems-by-qname baseName-elem *xtm1.0-ns* "variant")) @@ -248,13 +263,14 @@ (unless instanceOf (format t "from-occurrence-elem-xtm1.0: type is missing -> http://psi.topicmaps.org/iso13250/model/type-instance~%") (setf instanceOf (get-item-by-id "type-instance" :xtm-id "core.xtm"))) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes themes - :instance-of instanceOf - :charvalue (getf occurrence-value :data) - :datatype (getf occurrence-value :type)))) + (let ((occurrence (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes themes + :instance-of instanceOf + :charvalue (getf occurrence-value :data) + :datatype (getf occurrence-value :type)))) + (set-reifier-xtm1.0 occ-elem occurrence)))) (defun from-subjectIdentity-elem-xtm1.0 (subjectIdentity-elem start-revision) @@ -308,11 +324,17 @@ (xpath-child-elems-by-qname member-elem *xtm1.0-ns* - "subjectIndicatorRef")))))))) + "subjectIndicatorRef"))))))) + (reifier-uri + (when (dom:get-attribute-node member-elem "id") + (concatenate 'string "#" (dom:node-value (dom:get-attribute-node member-elem "id")))))) (declare (dom:element member-elem)) (unless player ; if no type is given a standard type will be assigend later in from-assoc... (error "from-member-elem-xtm1.0: missing player in role")) - (list :instance-of type :player (first player) :item-identifiers nil))))) + (list :instance-of type + :player (first player) + :item-identifiers nil + :reifier-uri reifier-uri))))) (defun from-topic-elem-to-stub-xtm1.0 (topic-elem start-revision @@ -399,9 +421,19 @@ :instance-of type :themes themes :roles roles))) - (add-to-topicmap tm association) - association)))) - + (add-to-topicmap tm association) + (set-reifier-xtm1.0 assoc-elem association) + (map 'list #'(lambda(assoc-role) + (map 'list #'(lambda(list-role) + (when (and (eql (instance-of assoc-role) + (getf list-role :instance-of)) + (eql (player assoc-role) + (getf list-role :player)) + (getf list-role :reifier-uri)) + (add-reifier assoc-role (getf list-role :reifier-uri) nil))) + roles)) + (roles association)))))) + (defun set-standard-role-types (roles) "sets the missing role types of the passed roles to the default types." Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sun Nov 22 15:11:48 2009 @@ -16,7 +16,7 @@ (let ((reifier-uri (get-attribute reifiable-elem "reifier"))) (when (and (stringp reifier-uri) (> (length reifier-uri) 0)) - (add-reifier reifiable-construct reifier-uri)) + (add-reifier reifiable-construct reifier-uri t)) reifiable-construct)) @@ -403,7 +403,7 @@ (eql (player assoc-role) (getf list-role :player)) (getf list-role :reifier-uri)) - (add-reifier assoc-role (getf list-role :reifier-uri)))) + (add-reifier assoc-role (getf list-role :reifier-uri) t))) roles)) (roles assoc)) (set-reifier assoc-elem assoc))))) From lgiessmann at common-lisp.net Mon Nov 23 19:02:31 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Mon, 23 Nov 2009 14:02:31 -0500 Subject: [isidorus-cvs] r147 - trunk/src/unit_tests Message-ID: Author: lgiessmann Date: Mon Nov 23 14:02:30 2009 New Revision: 147 Log: added a reification-test-file for the xtm1.0 importer Added: trunk/src/unit_tests/reification_xtm1.0.xtm (contents, props changed) Modified: trunk/src/unit_tests/reification_test.lisp Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Mon Nov 23 14:02:30 2009 @@ -207,9 +207,17 @@ (elephant:close-store)))))) -;;TODO: check xtm1.0 importer +(test test-xtm1.0-reification + "Tests the reification in the xtm1.0-importer." + + ) + + + ;;TODO: check xtm2.0 importer ;;TODO: check rdf importer +;;TODO: check xtm1.0 exporter +;;TODO: check xtm2.0 exporter ;;TODO: check fragment exporter Added: trunk/src/unit_tests/reification_xtm1.0.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/reification_xtm1.0.xtm Mon Nov 23 14:02:30 2009 @@ -0,0 +1,160 @@ + + + + + + + + + + + + + + + + + Homer Simpson + + + + Homer Jay Simpson + + + + + + + + Safety Inspector + + + + + + + + + Marge Simpson + + + + Marjorie Simpson + + + + + + + + Housewife + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From lgiessmann at common-lisp.net Tue Nov 24 15:26:43 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 24 Nov 2009 10:26:43 -0500 Subject: [isidorus-cvs] r148 - in trunk/src: . model unit_tests xml/xtm Message-ID: Author: lgiessmann Date: Tue Nov 24 10:26:43 2009 New Revision: 148 Log: fixed some problems in the "reification"-functions and added a unit-test for the xtm1.0 importer Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/unit_tests/reification_xtm1.0.xtm trunk/src/unit_tests/unittests-constants.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Nov 24 10:26:43 2009 @@ -111,6 +111,7 @@ (:static-file "poems_light.rdf") (:static-file "poems_light.xtm") (:static-file "full_mapping.rdf") + (:static-file "reification_xtm1.0.xtm") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Tue Nov 24 10:26:43 2009 @@ -614,12 +614,12 @@ (defgeneric reifier (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (when (slot-boundp construct 'reifier) - (filter-slot-value-by-revision construct 'reifier :start-revision revision)))) + (slot-value construct 'reifier)))) (defgeneric (setf reifier) (topic TopicC) (:method (topic (construct ReifiableConstructC)) - (setf (slot-value construct 'reifier) topic) - (setf (reified topic) construct))) + (setf (slot-value construct 'reifier) topic))) +; (setf (reified topic) construct))) (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) @@ -960,12 +960,12 @@ (defgeneric reified (topic &key revision) (:method ((topic TopicC) &key (revision *TM-REVISION*)) (when (slot-boundp topic 'reified) - (filter-slot-value-by-revision topic 'reified :start-revision revision)))) + (slot-value topic 'reified)))) (defgeneric (setf reified) (reifiable ReifiableConstructC) (:method (reifiable (topic TopicC)) - (setf (slot-value topic 'reified) reifiable) - (setf (reifier reifiable) topic))) + (setf (slot-value topic 'reified) reifiable))) +; (setf (reifier reifiable) topic))) (defgeneric occurrences (topic &key revision) (:method ((topic TopicC) &key (revision *TM-REVISION*)) @@ -1585,24 +1585,27 @@ ;;;;;;;;;;;;;;;;; ;; reification -(defgeneric add-reifier (construct reifier-uri reifier-must-exist) - (:method ((construct ReifiableConstructC) reifier-uri reifier-must-exist) +(defgeneric add-reifier (construct reifier-uri &key xtm-version) + (:method ((construct ReifiableConstructC) reifier-uri &key (xtm-version '2.0)) (let ((err "From add-reifier(): ")) - (let ((item-identifier - (elephant:get-instance-by-value 'ItemIdentifierC 'uri reifier-uri))) - (unless item-identifier - (when reifier-must-exist - (error "~ano item-identifier could be found with the uri ~a" + (let ((identifier + (elephant:get-instance-by-value (if (eql xtm-version '1.0) + 'PersistentIdC + 'ItemIdentifierC) 'uri reifier-uri))) + (unless identifier + (when (eql xtm-version '2.0) + (error "~ano identifier could be found with the uri ~a" err reifier-uri))) - (when item-identifier - (let ((reifier-topic (identified-construct item-identifier))) + (when identifier + (let ((reifier-topic (identified-construct identifier))) (unless (typep reifier-topic 'TopicC) - (error "~anitem-identifier ~a must be bound to a topic, but is ~a" + (error "~anidentifier ~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 (reifier construct) reifier-topic) + (setf (reified reifier-topic) construct)) ((and (not (reified reifier-topic)) (reifier construct)) (merge-reifier-topics (reifier construct) reifier-topic)) Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Tue Nov 24 10:26:43 2009 @@ -17,7 +17,8 @@ (:export :reification-test :run-reification-tests - :test-merge-reifier-topics)) + :test-merge-reifier-topics + :test-xtm1.0-reification)) (in-package :reification-test) @@ -209,9 +210,72 @@ (test test-xtm1.0-reification "Tests the reification in the xtm1.0-importer." - - ) - + (let + ((dir "data_base")) + (with-fixture initialize-destination-db (dir) + (xml-importer:import-xtm *reification_xtm1.0.xtm* dir + :tm-id "http://www.isidor.us/unittests/reification-xtm1.0-tests" + :xtm-id "reification-xtm" + :xtm-format '1.0) + (is (= (length (elephant:get-instances-by-class 'TopicC)) 12)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 1)) + (let ((homer + (identified-construct + (elephant:get-instance-by-value 'PersistentIdC 'uri "http://simpsons.tv/homer"))) + (married-assoc + (first (elephant:get-instances-by-class 'AssociationC)))) + (let ((homer-occurrence (first (occurrences homer))) + (homer-name (first (names homer))) + (homer-variant (first (variants (first (names homer))))) + (husband-role (find-if #'(lambda(x) + (eql (instance-of x) + (identified-construct + (elephant:get-instance-by-value + 'PersistentIdC 'uri "http://simpsons.tv/husband")))) + (roles married-assoc))) + (reifier-occurrence + (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#homer-occurrence"))) + (reifier-name + (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#homer-name"))) + (reifier-variant + (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#homer-name-variant"))) + (reifier-married-assoc + (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#a-married"))) + (reifier-husband-role + (identified-construct (elephant:get-instance-by-value 'PersistentIdC 'uri "#married-husband-role")))) + (is-true homer) + (is-true homer-occurrence) + (is-true homer-name) + (is-true homer-variant) + (is-true married-assoc) + (is-true husband-role) + (is-true reifier-occurrence) + (is-true reifier-name) + (is-true reifier-variant) + (is-true reifier-married-assoc) + (is-true reifier-husband-role) + (is (eql (reifier homer-occurrence) reifier-occurrence)) + (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reifier homer-name) reifier-name)) + (is (eql (reified reifier-name) homer-name)) + (is (eql (reifier homer-variant) reifier-variant)) + (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reifier married-assoc) reifier-married-assoc)) + (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reifier husband-role) reifier-husband-role)) + (is (eql (reified reifier-husband-role) husband-role)) + (is-true (handler-case + (progn (d::delete-construct homer-occurrence) + t) + (condition () nil))) + (is-false (occurrences homer)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) + (is-true (handler-case + (progn (d::delete-construct reifier-occurrence) + t) + (condition () nil))))) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (elephant:close-store)))) ;;TODO: check xtm2.0 importer @@ -219,8 +283,10 @@ ;;TODO: check xtm1.0 exporter ;;TODO: check xtm2.0 exporter ;;TODO: check fragment exporter +;;TODO: check merge-reifier-topics (--> versioning) (defun run-reification-tests () (it.bese.fiveam:run! 'test-merge-reifier-topics) + (it.bese.fiveam:run! 'test-xtm1.0-refication) ) \ No newline at end of file Modified: trunk/src/unit_tests/reification_xtm1.0.xtm ============================================================================== --- trunk/src/unit_tests/reification_xtm1.0.xtm (original) +++ trunk/src/unit_tests/reification_xtm1.0.xtm Tue Nov 24 10:26:43 2009 @@ -154,7 +154,7 @@ xmlns:xlink="http://www.w3.org/1999/xlink" id="married-husband-reifier"> - + Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Tue Nov 24 10:26:43 2009 @@ -31,7 +31,8 @@ :*atom-conf.lisp* :*poems_light.rdf* :*poems_light.xtm* - :*full_mapping.rdf*)) + :*full_mapping.rdf* + :*reification_xtm1.0.xtm*)) (in-package :unittests-constants) @@ -103,4 +104,8 @@ (defparameter *full_mapping.rdf* (asdf:component-pathname - (asdf:find-component *unit-tests-component* "full_mapping.rdf"))) \ No newline at end of file + (asdf:find-component *unit-tests-component* "full_mapping.rdf"))) + +(defparameter *reification_xtm1.0.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "reification_xtm1.0.xtm"))) \ No newline at end of file Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Tue Nov 24 10:26:43 2009 @@ -18,7 +18,7 @@ (dom:node-value (dom:get-attribute-node reifiable-elem "id"))))) (when (and (stringp reifier-uri) (> (length reifier-uri) 0)) - (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) nil)) + (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) :xtm-version '1.0)) reifiable-construct)) @@ -430,9 +430,10 @@ (eql (player assoc-role) (getf list-role :player)) (getf list-role :reifier-uri)) - (add-reifier assoc-role (getf list-role :reifier-uri) nil))) + (add-reifier assoc-role (getf list-role :reifier-uri) :xtm-version '1.0))) roles)) - (roles association)))))) + (roles association)) + association)))) (defun set-standard-role-types (roles) Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Tue Nov 24 10:26:43 2009 @@ -16,7 +16,7 @@ (let ((reifier-uri (get-attribute reifiable-elem "reifier"))) (when (and (stringp reifier-uri) (> (length reifier-uri) 0)) - (add-reifier reifiable-construct reifier-uri t)) + (add-reifier reifiable-construct reifier-uri :xtm-version '2.0)) reifiable-construct)) @@ -403,7 +403,7 @@ (eql (player assoc-role) (getf list-role :player)) (getf list-role :reifier-uri)) - (add-reifier assoc-role (getf list-role :reifier-uri) t))) + (add-reifier assoc-role (getf list-role :reifier-uri) :xtm-version '2.0))) roles)) (roles assoc)) (set-reifier assoc-elem assoc))))) From lgiessmann at common-lisp.net Tue Nov 24 15:56:10 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 24 Nov 2009 10:56:10 -0500 Subject: [isidorus-cvs] r149 - in trunk/src: . unit_tests Message-ID: Author: lgiessmann Date: Tue Nov 24 10:56:09 2009 New Revision: 149 Log: added an xtm2.0-reification test file Added: trunk/src/unit_tests/reification_xtm2.0.xtm (contents, props changed) Modified: trunk/src/isidorus.asd Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Nov 24 10:56:09 2009 @@ -112,6 +112,7 @@ (:static-file "poems_light.xtm") (:static-file "full_mapping.rdf") (:static-file "reification_xtm1.0.xtm") + (:static-file "reification_xtm2.0.xtm") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Added: trunk/src/unit_tests/reification_xtm2.0.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/reification_xtm2.0.xtm Tue Nov 24 10:56:09 2009 @@ -0,0 +1,94 @@ + + + + + + + + + + + + + + Homer Simpson + + + Homer Jay Simpson + + + + + Safety Inspector + + + + + + + Marge Simpson + + + Marjorie Simpson + + + + + Housewife + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + From lgiessmann at common-lisp.net Tue Nov 24 16:17:34 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Tue, 24 Nov 2009 11:17:34 -0500 Subject: [isidorus-cvs] r150 - trunk/src/unit_tests Message-ID: Author: lgiessmann Date: Tue Nov 24 11:17:34 2009 New Revision: 150 Log: added a unit-test for reification in the xtm2.0-importer Modified: trunk/src/unit_tests/reification_test.lisp trunk/src/unit_tests/reification_xtm2.0.xtm trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Tue Nov 24 11:17:34 2009 @@ -18,7 +18,8 @@ :reification-test :run-reification-tests :test-merge-reifier-topics - :test-xtm1.0-reification)) + :test-xtm1.0-reification + :test-xtm2.0-reification)) (in-package :reification-test) @@ -278,7 +279,75 @@ (elephant:close-store)))) -;;TODO: check xtm2.0 importer +(test test-xtm2.0-reification + "Tests the reification in the xtm2.0-importer." + (let + ((dir "data_base")) + (with-fixture initialize-destination-db (dir) + (xml-importer:import-xtm *reification_xtm2.0.xtm* dir + :tm-id "http://www.isidor.us/unittests/reification-xtm2.0-tests" + :xtm-id "reification-xtm") + (is (= (length (elephant:get-instances-by-class 'TopicC)) 12)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 1)) + (let ((homer + (identified-construct + (elephant:get-instance-by-value 'PersistentIdC 'uri "http://simpsons.tv/homer"))) + (married-assoc + (first (elephant:get-instances-by-class 'AssociationC)))) + (let ((homer-occurrence (first (occurrences homer))) + (homer-name (first (names homer))) + (homer-variant (first (variants (first (names homer))))) + (husband-role (find-if #'(lambda(x) + (eql (instance-of x) + (identified-construct + (elephant:get-instance-by-value + 'PersistentIdC 'uri "http://simpsons.tv/husband")))) + (roles married-assoc))) + (reifier-occurrence + (identified-construct (elephant:get-instance-by-value 'ItemIdentifierC 'uri "http://simpsons.tv/homer-occurrence"))) + (reifier-name + (identified-construct (elephant:get-instance-by-value 'ItemIdentifierC 'uri "http://simpsons.tv/homer-name"))) + (reifier-variant + (identified-construct (elephant:get-instance-by-value 'ItemIdentifierC 'uri "http://simpsons.tv/homer-name-variant"))) + (reifier-married-assoc + (identified-construct (elephant:get-instance-by-value 'ItemIdentifierC 'uri "http://simpsons.tv/married-association"))) + (reifier-husband-role + (identified-construct (elephant:get-instance-by-value 'ItemIdentifierC 'uri "http://simpsons.tv/married-husband-role")))) + (is-true homer) + (is-true homer-occurrence) + (is-true homer-name) + (is-true homer-variant) + (is-true married-assoc) + (is-true husband-role) + (is-true reifier-occurrence) + (is-true reifier-name) + (is-true reifier-variant) + (is-true reifier-married-assoc) + (is-true reifier-husband-role) + (is (eql (reifier homer-occurrence) reifier-occurrence)) + (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reifier homer-name) reifier-name)) + (is (eql (reified reifier-name) homer-name)) + (is (eql (reifier homer-variant) reifier-variant)) + (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reifier married-assoc) reifier-married-assoc)) + (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reifier husband-role) reifier-husband-role)) + (is (eql (reified reifier-husband-role) husband-role)) + (is-true (handler-case + (progn (d::delete-construct homer-occurrence) + t) + (condition () nil))) + (is-false (occurrences homer)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) + (is-true (handler-case + (progn (d::delete-construct reifier-occurrence) + t) + (condition () nil))))) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (elephant:close-store)))) + + ;;TODO: check rdf importer ;;TODO: check xtm1.0 exporter ;;TODO: check xtm2.0 exporter @@ -288,5 +357,6 @@ (defun run-reification-tests () (it.bese.fiveam:run! 'test-merge-reifier-topics) - (it.bese.fiveam:run! 'test-xtm1.0-refication) + (it.bese.fiveam:run! 'test-xtm1.0-reification) + (it.bese.fiveam:run! 'test-xtm2.0-reification) ) \ No newline at end of file Modified: trunk/src/unit_tests/reification_xtm2.0.xtm ============================================================================== --- trunk/src/unit_tests/reification_xtm2.0.xtm (original) +++ trunk/src/unit_tests/reification_xtm2.0.xtm Tue Nov 24 11:17:34 2009 @@ -39,23 +39,23 @@ - + - + - + - + - + Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Tue Nov 24 11:17:34 2009 @@ -32,7 +32,8 @@ :*poems_light.rdf* :*poems_light.xtm* :*full_mapping.rdf* - :*reification_xtm1.0.xtm*)) + :*reification_xtm1.0.xtm* + :*reification_xtm2.0.xtm*)) (in-package :unittests-constants) @@ -108,4 +109,8 @@ (defparameter *reification_xtm1.0.xtm* (asdf:component-pathname - (asdf:find-component *unit-tests-component* "reification_xtm1.0.xtm"))) \ No newline at end of file + (asdf:find-component *unit-tests-component* "reification_xtm1.0.xtm"))) + +(defparameter *reification_xtm2.0.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "reification_xtm2.0.xtm"))) \ No newline at end of file From lgiessmann at common-lisp.net Wed Nov 25 08:39:27 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 25 Nov 2009 03:39:27 -0500 Subject: [isidorus-cvs] r151 - in trunk/src: model unit_tests xml/xtm Message-ID: Author: lgiessmann Date: Wed Nov 25 03:39:26 2009 New Revision: 151 Log: restructured some functions of the importer which are responsible for reifcation; adapted the corresponding unit-tests Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/xml/xtm/importer_xtm1.0.lisp trunk/src/xml/xtm/importer_xtm2.0.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Wed Nov 25 03:39:26 2009 @@ -1585,40 +1585,30 @@ ;;;;;;;;;;;;;;;;; ;; reification -(defgeneric add-reifier (construct reifier-uri &key xtm-version) - (:method ((construct ReifiableConstructC) reifier-uri &key (xtm-version '2.0)) +(defgeneric add-reifier (construct reifier-topic) + (:method ((construct ReifiableConstructC) reifier-topic) (let ((err "From add-reifier(): ")) - (let ((identifier - (elephant:get-instance-by-value (if (eql xtm-version '1.0) - 'PersistentIdC - 'ItemIdentifierC) 'uri reifier-uri))) - (unless identifier - (when (eql xtm-version '2.0) - (error "~ano identifier could be found with the uri ~a" - err reifier-uri))) - (when identifier - (let ((reifier-topic (identified-construct identifier))) - (unless (typep reifier-topic 'TopicC) - (error "~anidentifier ~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)) + (declare (TopicC 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 ~a reifies already another object ~a" + err (psis reifier-topic) (item-identifiers reifier-topic) + (reified reifier-topic))) + (t + (when (not (eql (reified reifier-topic) construct)) + (error "~a~a ~a reifies already another object ~a" + err (psis reifier-topic) (item-identifiers reifier-topic) + (reified reifier-topic))) + (merge-reifier-topics (reifier construct) reifier-topic))) + construct))) (defgeneric merge-reifier-topics (old-topic new-topic) Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Wed Nov 25 03:39:26 2009 @@ -353,6 +353,7 @@ ;;TODO: check xtm2.0 exporter ;;TODO: check fragment exporter ;;TODO: check merge-reifier-topics (--> versioning) +;;TODO: extend the fragment-importer in the RESTful-interface (defun run-reification-tests () Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Wed Nov 25 03:39:26 2009 @@ -18,8 +18,14 @@ (dom:node-value (dom:get-attribute-node reifiable-elem "id"))))) (when (and (stringp reifier-uri) (> (length reifier-uri) 0)) - (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) :xtm-version '1.0)) - reifiable-construct)) + (let ((psi + (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri + (concatenate 'string "#" reifier-uri)))) + (when psi + (let ((reifier-topic (identified-construct psi))) + (when reifier-topic + (add-reifier reifiable-construct reifier-topic))))))) + reifiable-construct) (defun get-topic-id-xtm1.0 (topic-elem) @@ -408,7 +414,6 @@ (from-member-elem-xtm1.0 member-elem :xtm-id xtm-id)) (xpath-child-elems-by-qname assoc-elem *xtm1.0-ns* "member")))) - ;(format t "type: ~A~%themes: ~A~%roles: ~A~%~%" type themes roles) (unless roles (error "from-association-elem-xtm1.0: roles are missing in association")) (setf roles (set-standard-role-types roles)) @@ -430,7 +435,16 @@ (eql (player assoc-role) (getf list-role :player)) (getf list-role :reifier-uri)) - (add-reifier assoc-role (getf list-role :reifier-uri) :xtm-version '1.0))) + (let ((reifier-uri (getf list-role :reifier-uri))) + (when (and (stringp reifier-uri) + (> (length reifier-uri) 0)) + (let ((psi + (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri + reifier-uri))) + (when psi + (let ((reifier-topic (identified-construct psi))) + (when reifier-topic + (add-reifier assoc-role reifier-topic))))))))) roles)) (roles association)) association)))) Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm2.0.lisp Wed Nov 25 03:39:26 2009 @@ -13,11 +13,19 @@ "Sets the reifier-topic of the passed elem to the passed construct." (declare (dom:element reifiable-elem)) (declare (ReifiableConstructC reifiable-construct)) - (let ((reifier-uri (get-attribute reifiable-elem "reifier"))) + (let ((reifier-uri (get-attribute reifiable-elem "reifier")) + (err "From set-reifier(): ")) (when (and (stringp reifier-uri) (> (length reifier-uri) 0)) - (add-reifier reifiable-construct reifier-uri :xtm-version '2.0)) - reifiable-construct)) + (let ((ii + (elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri reifier-uri))) + (if ii + (let ((reifier-topic (identified-construct ii))) + (if reifier-topic + (add-reifier reifiable-construct reifier-topic) + (error "~aitem-identifier ~a not found" err reifier-uri))) + (error "~aitem-identifier ~a not found" err reifier-uri))))) + reifiable-construct) (defun from-identifier-elem (classsymbol elem start-revision) @@ -367,7 +375,8 @@ (declare (TopicMapC tm)) (elephant:ensure-transaction (:txn-nosync t) (let - ((item-identifiers + ((err "From from-association-elem(): ") + (item-identifiers (make-identifiers 'ItemIdentifierC assoc-elem "itemIdentity" start-revision)) (instance-of (from-type-elem @@ -403,7 +412,18 @@ (eql (player assoc-role) (getf list-role :player)) (getf list-role :reifier-uri)) - (add-reifier assoc-role (getf list-role :reifier-uri) :xtm-version '2.0))) + (let ((reifier-uri (getf list-role :reifier-uri))) + (when (and (stringp reifier-uri) + (> (length reifier-uri) 0)) + (let ((ii + (elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri + reifier-uri))) + (if ii + (let ((reifier-topic (identified-construct ii))) + (if reifier-topic + (add-reifier assoc-role reifier-topic) + (error "~aitem-identifier ~a not found" err reifier-uri))) + (error "~aitem-identifier ~a not found" err reifier-uri))))))) roles)) (roles assoc)) (set-reifier assoc-elem assoc))))) From lgiessmann at common-lisp.net Wed Nov 25 13:05:03 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 25 Nov 2009 08:05:03 -0500 Subject: [isidorus-cvs] r152 - in trunk/src: model unit_tests xml/xtm Message-ID: Author: lgiessmann Date: Wed Nov 25 08:05:02 2009 New Revision: 152 Log: added the support for reification to the xtm1.0 exporter; added alos some unit-tests for the exporter Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/xml/xtm/exporter_xtm1.0.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Wed Nov 25 08:05:02 2009 @@ -1245,9 +1245,9 @@ (if tm (remove-if-not (lambda (role) - (format t "player: ~a" (player role)) - (format t "parent: ~a" (parent role)) - (format t "topic: ~a~&" topic) + ;(format t "player: ~a" (player role)) + ;(format t "parent: ~a" (parent role)) + ;(format t "topic: ~a~&" topic) (in-topicmap tm (parent role))) (player-in-roles topic)) (player-in-roles topic))))) Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Wed Nov 25 08:05:02 2009 @@ -13,13 +13,22 @@ :datamodel :it.bese.FiveAM :unittests-constants - :fixtures) + :fixtures + :exporter) + (:import-from :constants + *xtm2.0-ns* + *xtm1.0-ns* + *xtm1.0-xlink*) + (:import-from :xml-tools + xpath-child-elems-by-qname xpath-single-child-elem-by-qname + xpath-fn-string) (:export :reification-test :run-reification-tests :test-merge-reifier-topics :test-xtm1.0-reification - :test-xtm2.0-reification)) + :test-xtm2.0-reification + :test-xtm1.0-reification-exporter)) (in-package :reification-test) @@ -348,8 +357,99 @@ (elephant:close-store)))) +(test test-xtm1.0-reification-exporter + "Tests the reification in the xtm1.0-exporter." + (let + ((dir "data_base") + (output-file "__out__.xtm") + (tm-id "http://www.isidor.us/unittests/reification-xtm1.0-tests")) + (with-fixture initialize-destination-db (dir) + (handler-case (delete-file output-file) + (error () )) ;do nothing + (xml-importer:import-xtm *reification_xtm1.0.xtm* dir + :tm-id tm-id + :xtm-id "reification-xtm" + :xtm-format '1.0) + (export-xtm output-file :xtm-format '1.0 :tm-id tm-id) + (let ((document + (dom:document-element + (cxml:parse-file output-file (cxml-dom:make-dom-builder))))) + (let ((homer-topic + (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") + when (loop for subjectIndicatorRef across (xpath-child-elems-by-qname + (xpath-single-child-elem-by-qname + topic *xtm1.0-ns* "subjectIdentity") + *xtm1.0-ns* "subjectIndicatorRef") + when (string= (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href") + "http://simpsons.tv/homer") + return t) + return topic)) + (married-assoc (xpath-single-child-elem-by-qname document *xtm1.0-ns* "association"))) + (is-true homer-topic) + (is-true married-assoc) + (loop for occurrence across (xpath-child-elems-by-qname homer-topic *xtm1.0-ns* "occurrence") + do (is (string= (dom:get-attribute occurrence "id") "homer-occurrence"))) + (loop for name across (xpath-child-elems-by-qname homer-topic *xtm1.0-ns* "baseName") + do (progn (is (string= (dom:get-attribute name "id") "homer-name")) + (loop for variant across (xpath-child-elems-by-qname name *xtm1.0-ns* "variant") + do (is (string= (dom:get-attribute variant "id") "homer-name-variant"))))) + (is (string= (dom:get-attribute married-assoc "id") "a-married")) + (is-true (loop for role across (xpath-child-elems-by-qname married-assoc *xtm1.0-ns* "member") + when (string= (dom:get-attribute role "id") + "married-husband-role") + return t))) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") + when (loop for subjectIndicatorRef across (xpath-child-elems-by-qname + (xpath-single-child-elem-by-qname + topic *xtm1.0-ns* "subjectIdentity") + *xtm1.0-ns* "subjectIndicatorRef") + when (string= (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href") + "#homer-occurrence") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") + when (loop for subjectIndicatorRef across (xpath-child-elems-by-qname + (xpath-single-child-elem-by-qname + topic *xtm1.0-ns* "subjectIdentity") + *xtm1.0-ns* "subjectIndicatorRef") + when (string= (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href") + "#homer-name") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") + when (loop for subjectIndicatorRef across (xpath-child-elems-by-qname + (xpath-single-child-elem-by-qname + topic *xtm1.0-ns* "subjectIdentity") + *xtm1.0-ns* "subjectIndicatorRef") + when (string= (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href") + "#homer-name-variant") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") + when (loop for subjectIndicatorRef across (xpath-child-elems-by-qname + (xpath-single-child-elem-by-qname + topic *xtm1.0-ns* "subjectIdentity") + *xtm1.0-ns* "subjectIndicatorRef") + when (string= (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href") + "#a-married") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") + when (loop for subjectIndicatorRef across (xpath-child-elems-by-qname + (xpath-single-child-elem-by-qname + topic *xtm1.0-ns* "subjectIdentity") + *xtm1.0-ns* "subjectIndicatorRef") + when (string= (dom:get-attribute-ns subjectIndicatorRef *xtm1.0-xlink* "href") + "#married-husband-role") + return t) + return t))) + (handler-case (delete-file output-file) + (error () )) ;do nothing + (elephant:close-store)))) + + + ;;TODO: check rdf importer -;;TODO: check xtm1.0 exporter ;;TODO: check xtm2.0 exporter ;;TODO: check fragment exporter ;;TODO: check merge-reifier-topics (--> versioning) @@ -360,4 +460,5 @@ (it.bese.fiveam:run! 'test-merge-reifier-topics) (it.bese.fiveam:run! 'test-xtm1.0-reification) (it.bese.fiveam:run! 'test-xtm2.0-reification) + (it.bese.fiveam:run! 'test-xtm1.0-reification-exporter) ) \ No newline at end of file Modified: trunk/src/xml/xtm/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm1.0.lisp Wed Nov 25 08:05:02 2009 @@ -34,6 +34,23 @@ (cxml:attribute "xlink:href" (format nil "#~a" (topicid topic))))) +(defun to-reifier-elem-xtm1.0 (reifiable-construct) + "Exports an ID indicating a reifier. + The reifier is only exported if the reifier-topic contains a PSI starting with #. + This may cause differences since the xtm2.0 defines the referencing + of reifiers with item-identifiers." + (declare (ReifiableConstructC reifiable-construct)) + (when (reifier reifiable-construct) + (let ((reifier-psi + (find-if #'(lambda(x) + (when (and (stringp (uri x)) + (> (length (uri x)) 0)) + (eql (elt (uri x) 0) #\#))) + (psis (reifier reifiable-construct))))) + (when reifier-psi + (cxml:attribute "id" (subseq (uri reifier-psi) 1 (length (uri reifier-psi)))))))) + + (defun to-resourceX-elem-xtm1.0 (characteristic) (declare (CharacteristicC characteristic)) (let ((characteristic-value @@ -90,6 +107,7 @@ (defmethod to-elem-xtm1.0 ((variant VariantC)) "variant = element { parameters, variantName?, variant* }" (cxml:with-element "t:variant" + (to-reifier-elem-xtm1.0 variant) (when (themes variant) (cxml:with-element "t:parameters" (map 'list #'to-topicRef-elem-xtm1.0 (themes variant)))) @@ -100,6 +118,7 @@ (defmethod to-elem-xtm1.0 ((name NameC)) "baseName = element baseName { scope?, baseNameString, variant* }" (cxml:with-element "t:baseName" + (to-reifier-elem-xtm1.0 name) (when (themes name) (to-scope-elem-xtm1.0 name)) (cxml:with-element "t:baseNameString" @@ -114,6 +133,7 @@ "occurrence = element occurrence { instanceOf?, scope?, (resourceRef | resourceData) }" (cxml:with-element "t:occurrence" + (to-reifier-elem-xtm1.0 occurrence) (when (instance-of occurrence) (to-instanceOf-elem-xtm1.0 (instance-of occurrence))) (when (themes occurrence) @@ -146,6 +166,7 @@ "member = element member { roleSpec?, (topicRef | resourceRef | subjectIndicatorRef)+ }" (cxml:with-element "t:member" + (to-reifier-elem-xtm1.0 role) (when (instance-of role) (to-roleSpec-elem-xtm1.0 (instance-of role))) (to-topicRef-elem-xtm1.0 (player role)))) @@ -154,6 +175,7 @@ (defmethod to-elem-xtm1.0 ((association AssociationC)) "association = element association { instanceOf?, scope?, member+ }" (cxml:with-element "t:association" + (to-reifier-elem-xtm1.0 association) (when (instance-of association) (to-instanceOf-elem-xtm1.0 (instance-of association))) (when (themes association) From lgiessmann at common-lisp.net Wed Nov 25 14:47:33 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Wed, 25 Nov 2009 09:47:33 -0500 Subject: [isidorus-cvs] r153 - in trunk/src: unit_tests xml/xtm Message-ID: Author: lgiessmann Date: Wed Nov 25 09:47:32 2009 New Revision: 153 Log: added reification-support to the xtm2.0-exporter; added also some unit-tests for several cases in the exporter Modified: trunk/src/unit_tests/reification_test.lisp trunk/src/xml/xtm/exporter_xtm2.0.lisp Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Wed Nov 25 09:47:32 2009 @@ -28,7 +28,8 @@ :test-merge-reifier-topics :test-xtm1.0-reification :test-xtm2.0-reification - :test-xtm1.0-reification-exporter)) + :test-xtm1.0-reification-exporter + :test-xtm2.0-reification-exporter)) (in-package :reification-test) @@ -446,11 +447,73 @@ (handler-case (delete-file output-file) (error () )) ;do nothing (elephant:close-store)))) - + +(test test-xtm2.0-reification-exporter + "Tests the reification in the xtm2.0-exporter." + (let + ((dir "data_base") + (output-file "__out__.xtm") + (tm-id "http://www.isidor.us/unittests/reification-xtm2.0-tests")) + (with-fixture initialize-destination-db (dir) + (handler-case (delete-file output-file) + (error () )) ;do nothing + (xml-importer:import-xtm *reification_xtm2.0.xtm* dir + :tm-id tm-id + :xtm-id "reification-xtm") + (export-xtm output-file :tm-id tm-id) + (let ((document + (dom:document-element + (cxml:parse-file output-file (cxml-dom:make-dom-builder))))) + (let ((homer-topic + (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") + when (loop for psi across (xpath-child-elems-by-qname topic *xtm2.0-ns* "subjectIdentifier") + when (string= (dom:get-attribute psi "href") "http://simpsons.tv/homer") + return t) + return topic)) + (married-assoc (xpath-single-child-elem-by-qname document *xtm2.0-ns* "association"))) + (is-true homer-topic) + (is-true married-assoc) + (loop for occurrence across (xpath-child-elems-by-qname homer-topic *xtm2.0-ns* "occurrence") + do (is (string= (dom:get-attribute occurrence "reifier") "http://simpsons.tv/homer-occurrence"))) + (loop for name across (xpath-child-elems-by-qname homer-topic *xtm2.0-ns* "name") + do (is (string= (dom:get-attribute name "reifier") "http://simpsons.tv/homer-name"))) + (loop for name across (xpath-child-elems-by-qname homer-topic *xtm2.0-ns* "name") + do (loop for variant across (xpath-child-elems-by-qname name *xtm2.0-ns* "variant") + do (is (string= (dom:get-attribute variant "reifier") "http://simpsons.tv/homer-name-variant")))) + (is (string= (dom:get-attribute married-assoc "reifier") "http://simpsons.tv/married-association")) + (is-true (loop for role across (xpath-child-elems-by-qname married-assoc *xtm2.0-ns* "role") + when (string= (dom:get-attribute role "reifier") "http://simpsons.tv/married-husband-role") + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") + when (loop for ii across (xpath-child-elems-by-qname topic *xtm2.0-ns* "itemIdentity") + when (string= (dom:get-attribute ii "href") "http://simpsons.tv/homer-occurrence") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") + when (loop for ii across (xpath-child-elems-by-qname topic *xtm2.0-ns* "itemIdentity") + when (string= (dom:get-attribute ii "href") "http://simpsons.tv/homer-name") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") + when (loop for ii across (xpath-child-elems-by-qname topic *xtm2.0-ns* "itemIdentity") + when (string= (dom:get-attribute ii "href") "http://simpsons.tv/homer-name-variant") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") + when (loop for ii across (xpath-child-elems-by-qname topic *xtm2.0-ns* "itemIdentity") + when (string= (dom:get-attribute ii "href") "http://simpsons.tv/married-association") + return t) + return t)) + (is-true (loop for topic across (xpath-child-elems-by-qname document *xtm2.0-ns* "topic") + when (loop for ii across (xpath-child-elems-by-qname topic *xtm2.0-ns* "itemIdentity") + when (string= (dom:get-attribute ii "href") "http://simpsons.tv/married-husband-role") + return t) + return t))))) + (elephant:close-store))) + ;;TODO: check rdf importer -;;TODO: check xtm2.0 exporter ;;TODO: check fragment exporter ;;TODO: check merge-reifier-topics (--> versioning) ;;TODO: extend the fragment-importer in the RESTful-interface @@ -461,4 +524,4 @@ (it.bese.fiveam:run! 'test-xtm1.0-reification) (it.bese.fiveam:run! 'test-xtm2.0-reification) (it.bese.fiveam:run! 'test-xtm1.0-reification-exporter) - ) \ No newline at end of file + (it.bese.fiveam:run! 'test-xtm2.0-reification-exporter)) \ No newline at end of file Modified: trunk/src/xml/xtm/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/xtm/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/xtm/exporter_xtm2.0.lisp Wed Nov 25 09:47:32 2009 @@ -9,6 +9,16 @@ (in-package :exporter) +(defun to-reifier-elem (reifiable-construct) + "Exports the reifier-attribute. + The attribute is only exported if the reifier-topic contains at least + one item-identifier." + (declare (ReifiableConstructC reifiable-construct)) + (when (and (reifier reifiable-construct) + (item-identifiers (reifier reifiable-construct))) + (cxml:attribute "reifier" + (uri (first (item-identifiers (reifier reifiable-construct))))))) + (defun ref-to-elem (topic) (declare (TopicC topic)) (cxml:with-element "t:topicRef" @@ -29,6 +39,7 @@ "name = element name { reifiable, type?, scope?, value, variant* }" (cxml:with-element "t:name" + (to-reifier-elem name) (map 'list #'to-elem (item-identifiers name)) (when (slot-boundp name 'instance-of) (cxml:with-element "t:type" @@ -74,6 +85,7 @@ (defmethod to-elem ((variant VariantC)) "variant = element variant { reifiable, scope, (resourceRef | resourceData) }" (cxml:with-element "t:variant" + (to-reifier-elem variant) (map 'list #'to-elem (item-identifiers variant)) (when (themes variant) (cxml:with-element "t:scope" @@ -91,6 +103,7 @@ "occurrence = element occurrence { reifiable, type, scope?, (resourceRef | resourceData) }" (cxml:with-element "t:occurrence" + (to-reifier-elem occ) (map 'list #'to-elem (item-identifiers occ)) (cxml:with-element "t:type" (ref-to-elem (instance-of occ))) @@ -138,6 +151,7 @@ (defmethod to-elem ((role RoleC)) "role = element role { reifiable, type, topicRef }" (cxml:with-element "t:role" + (to-reifier-elem role) (map 'list #'to-elem (item-identifiers role)) (cxml:with-element "t:type" (ref-to-elem (instance-of role))) @@ -147,6 +161,7 @@ (defmethod to-elem ((assoc AssociationC)) "association = element association { reifiable, type, scope?, role+ }" (cxml:with-element "t:association" + (to-reifier-elem assoc) (map 'list #'to-elem (item-identifiers assoc)) (cxml:with-element "t:type" (ref-to-elem (instance-of assoc))) From lgiessmann at common-lisp.net Thu Nov 26 10:40:45 2009 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 26 Nov 2009 05:40:45 -0500 Subject: [isidorus-cvs] r154 - in trunk/src: unit_tests xml/rdf Message-ID: Author: lgiessmann Date: Thu Nov 26 05:40:44 2009 New Revision: 154 Log: changed the reification handling in the rdf-importer, so all reifiable-constructs are reified by other resources by the reifier-slot --> added some unit-tests Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/reification_test.lisp trunk/src/xml/rdf/importer.lisp Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Thu Nov 26 05:40:44 2009 @@ -58,7 +58,6 @@ :test-get-associations-of-node-content :test-parse-properties-of-node :test-import-node-1 - :test-import-node-reification :test-import-dom :test-poems-rdf-occurrences :test-poems-rdf-associations @@ -1218,236 +1217,6 @@ (is-false (d:psis (d:player object-role)))))))))))) (elephant:close-store)) - -(test test-import-node-reification - "Tests the function import-node non-recursively. Especially the reification - of association- and occurrence-arcs." - (let ((db-dir "data_base") - (tm-id "http://test-tm/") - (revision-1 100) - (document-id "doc-id") - (doc-1 - (concatenate 'string "" - "" - "" - "" - "" - "" - "" - "" - "" - "" - "" - "occurrence data" - "" - "" - "" - "" - "" - ""))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) - (is-true dom-1) - (is (= (length (dom:child-nodes dom-1)) 1)) - (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) - (is (= (length (dom:child-nodes rdf-node)) 4)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (dotimes (iter (length (dom:child-nodes rdf-node))) - (rdf-importer::import-node (elt (dom:child-nodes rdf-node) iter) - tm-id revision-1 - :document-id document-id)) - (let ((reification-1 (d:get-item-by-id "http://test-tm#reification-1" - :xtm-id document-id)) - (reification-2 (d:get-item-by-id "http://test-tm#reification-2" - :xtm-id document-id)) - (first-node (d:get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) - (second-node (d:get-item-by-id "http://test-tm/second-node" - :xtm-id document-id)) - (third-node (d:get-item-by-id "http://test-tm/third-node" - :xtm-id document-id)) - (fourth-node (d:get-item-by-id "fourth-node" - :xtm-id document-id)) - (fifth-node (d:get-item-by-id "http://test-tm/fifth-node" - :xtm-id document-id)) - (arc1 (d:get-item-by-id "http://test/arcs/arc1" - :xtm-id document-id)) - (arc2 (d:get-item-by-id "http://test/arcs/arc2" - :xtm-id document-id)) - (arc3 (d:get-item-by-id "http://test/arcs/arc3" - :xtm-id document-id)) - (arc4 (d:get-item-by-id "http://test/arcs/arc4" - :xtm-id document-id)) - (statement (d:get-item-by-psi *rdf-statement*)) - (object (d:get-item-by-psi *rdf-object*)) - (subject (d:get-item-by-psi *rdf-subject*)) - (predicate (d:get-item-by-psi *rdf-predicate*)) - (type (d:get-item-by-psi *type-psi*)) - (instance (d:get-item-by-psi *instance-psi*)) - (type-instance (d:get-item-by-psi *type-instance-psi*)) - (isi-subject (d:get-item-by-psi *rdf2tm-subject*)) - (isi-object (d:get-item-by-psi *rdf2tm-object*))) - (is (= (length (d:psis reification-1)) 1)) - (is (string= (d:uri (first (d:psis reification-1))) - "http://test-tm#reification-1")) - (is (= (length (d:psis reification-2)) 1)) - (is (string= (d:uri (first (d:psis reification-2))) - "http://test-tm#reification-2")) - (is (= (length (d:psis first-node)) 1)) - (is (string= (d:uri (first (d:psis first-node))) - "http://test-tm/first-node")) - (is (= (length (d:psis second-node)) 1)) - (is (string= (d:uri (first (d:psis second-node))) - "http://test-tm/second-node")) - (is (= (length (d:psis third-node)) 1)) - (is (string= (d:uri (first (d:psis third-node))) - "http://test-tm/third-node")) - (is (= (length (d:psis fourth-node)) 0)) - (is (= (length (d:psis fifth-node)) 1)) - (is (string= (d:uri (first (d:psis fifth-node))) - "http://test-tm/fifth-node")) - (is (= (length (d:psis arc1)) 1)) - (is (string= (d:uri (first (d:psis arc1))) - "http://test/arcs/arc1")) - (is (= (length (d:psis arc2)))) - (is (string= (d:uri (first (d:psis arc2))) - "http://test/arcs/arc2")) - (is (= (length (d:psis arc3)))) - (is (string= (d:uri (first (d:psis arc3))) - "http://test/arcs/arc3")) - (is (= (length (d:psis arc4)))) - (is (string= (d:uri (first (d:psis arc4))) - "http://test/arcs/arc4")) - (is-true statement) - (is-true object) - (is-true subject) - (is-true predicate) - (is-true type) - (is-true instance) - (is-true type-instance) - (is (= (length (d:player-in-roles first-node)) 2)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) arc1))) - (d:player-in-roles first-node))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - subject))) - (d:player-in-roles first-node))) - (is (= (length (d:player-in-roles second-node)) 2)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) arc1))) - (d:player-in-roles second-node))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - object))) - (d:player-in-roles second-node))) - (is (= (length (d:player-in-roles statement)) 2)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) type) - (eql (d:instance-of (d:parent x)) - type-instance))) - (d:player-in-roles statement))) - (is (= (length (d:player-in-roles arc1)) 1)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - predicate))) - (d:player-in-roles arc1))) - (is (= (length (d:player-in-roles third-node)) 1)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - arc2))) - (d:player-in-roles third-node))) - (is (= (length (d:player-in-roles reification-1)) 5)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - subject))) - (d:player-in-roles reification-1))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - object))) - (d:player-in-roles reification-1))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) instance) - (eql (d:instance-of (d:parent x)) - type-instance))) - (d:player-in-roles reification-1))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - object))) - (d:player-in-roles reification-1))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - predicate))) - (d:player-in-roles reification-1))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - arc2))) - (d:player-in-roles reification-1))) - (is (= (length (d:occurrences fourth-node)) 1)) - (is (string= (d:charvalue (first (d:occurrences fourth-node))) - "occurrence data")) - (is (string= (d:datatype (first (d:occurrences fourth-node))) - "http://test-tm/dt")) - (is (eql (d:instance-of (first (d:occurrences fourth-node))) - arc3)) - (is (= (length (d:player-in-roles fourth-node)) 1)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - subject))) - (d:player-in-roles fourth-node))) - (is (= (length (d:player-in-roles arc3)) 1)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - predicate))) - (d:player-in-roles arc3))) - (is (= (length (d:player-in-roles fifth-node)) 1)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-object) - (eql (d:instance-of (d:parent x)) - arc4))) - (d:player-in-roles fifth-node))) - (is (= (length (d:occurrences reification-2)) 1)) - (is (string= (d:charvalue (first (d:occurrences reification-2))) - "occurrence data")) - (is (string= (d:datatype (first (d:occurrences reification-2))) - "http://test-tm/dt")) - (is (= (length (d:player-in-roles reification-2)) 4)) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - subject))) - (d:player-in-roles reification-2))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - predicate))) - (d:player-in-roles reification-2))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) isi-subject) - (eql (d:instance-of (d:parent x)) - arc4))) - (d:player-in-roles reification-2))) - (is-true (find-if #'(lambda(x) - (and (eql (d:instance-of x) instance) - (eql (d:instance-of (d:parent x)) - type-instance))) - (d:player-in-roles reification-2))) - (elephant:close-store)))))) - (test test-import-dom "Tests the function import-node when used recursively." @@ -3385,7 +3154,6 @@ (it.bese.fiveam:run! 'test-get-associations-of-node-content) (it.bese.fiveam:run! 'test-parse-properties-of-node) (it.bese.fiveam:run! 'test-import-node-1) - (it.bese.fiveam:run! 'test-import-node-reification) (it.bese.fiveam:run! 'test-import-dom) (it.bese.fiveam:run! 'test-poems-rdf-occurrences) (it.bese.fiveam:run! 'test-poems-rdf-associations) Modified: trunk/src/unit_tests/reification_test.lisp ============================================================================== --- trunk/src/unit_tests/reification_test.lisp (original) +++ trunk/src/unit_tests/reification_test.lisp Thu Nov 26 05:40:44 2009 @@ -18,7 +18,14 @@ (:import-from :constants *xtm2.0-ns* *xtm1.0-ns* - *xtm1.0-xlink*) + *xtm1.0-xlink* + *rdf-ns* + *rdfs-ns* + *type-psi* + *instance-psi* + *type-instance-psi* + *rdf2tm-subject* + *rdf2tm-object*) (:import-from :xml-tools xpath-child-elems-by-qname xpath-single-child-elem-by-qname xpath-fn-string) @@ -29,7 +36,8 @@ :test-xtm1.0-reification :test-xtm2.0-reification :test-xtm1.0-reification-exporter - :test-xtm2.0-reification-exporter)) + :test-xtm2.0-reification-exporter + :test-rdf-importer-reification)) (in-package :reification-test) @@ -448,6 +456,7 @@ (error () )) ;do nothing (elephant:close-store)))) + (test test-xtm2.0-reification-exporter "Tests the reification in the xtm2.0-exporter." (let @@ -510,12 +519,119 @@ return t) return t))))) (elephant:close-store))) - + + +(test test-rdf-importer-reification + "Tests the function import-node non-recursively. Especially the reification + of association- and occurrence-arcs." + (let ((db-dir "data_base") + (tm-id "http://test-tm/") + (revision-1 100) + (document-id "doc-id") + (doc-1 + (concatenate 'string "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "occurrence data" + "" + "" + "" + "" + "" + ""))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is-true dom-1) + (is (= (length (dom:child-nodes dom-1)) 1)) + (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) + (is (= (length (dom:child-nodes rdf-node)) 4)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (dotimes (iter (length (dom:child-nodes rdf-node))) + (rdf-importer::import-node (elt (dom:child-nodes rdf-node) iter) + tm-id revision-1 + :document-id document-id)) + (is (= (length (dom:child-nodes rdf-node)) 4)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (dotimes (iter (length (dom:child-nodes rdf-node))) + (rdf-importer::import-node (elt (dom:child-nodes rdf-node) iter) + tm-id revision-1 + :document-id document-id)) + (let ((reification-1 (d:get-item-by-id "http://test-tm#reification-1" + :xtm-id document-id)) + (reification-2 (d:get-item-by-id "http://test-tm#reification-2" + :xtm-id document-id)) + (first-node (d:get-item-by-id "http://test-tm/first-node" + :xtm-id document-id)) + (second-node (d:get-item-by-id "http://test-tm/second-node" + :xtm-id document-id)) + (third-node (d:get-item-by-id "http://test-tm/third-node" + :xtm-id document-id)) + (fourth-node (d:get-item-by-id "fourth-node" + :xtm-id document-id)) + (fifth-node (d:get-item-by-id "http://test-tm/fifth-node" + :xtm-id document-id)) + (arc1 (d:get-item-by-id "http://test/arcs/arc1" + :xtm-id document-id)) + (arc2 (d:get-item-by-id "http://test/arcs/arc2" + :xtm-id document-id)) + (arc3 (d:get-item-by-id "http://test/arcs/arc3" + :xtm-id document-id)) + (arc4 (d:get-item-by-id "http://test/arcs/arc4" + :xtm-id document-id))) + (is (= (length (d:psis reification-1)) 1)) + (is (string= (d:uri (first (d:psis reification-1))) + "http://test-tm#reification-1")) + (is (= (length (d:psis reification-2)) 1)) + (is (string= (d:uri (first (d:psis reification-2))) + "http://test-tm#reification-2")) + (is (= (length (d:psis first-node)) 1)) + (is (string= (d:uri (first (d:psis first-node))) + "http://test-tm/first-node")) + (is (= (length (d:psis second-node)) 1)) + (is (string= (d:uri (first (d:psis second-node))) + "http://test-tm/second-node")) + (is (= (length (d:psis third-node)) 1)) + (is (string= (d:uri (first (d:psis third-node))) + "http://test-tm/third-node")) + (is (= (length (d:psis fourth-node)) 0)) + (is (= (length (d:psis fifth-node)) 1)) + (is (string= (d:uri (first (d:psis fifth-node))) + "http://test-tm/fifth-node")) + (is (= (length (d:psis arc1)) 1)) + (is (string= (d:uri (first (d:psis arc1))) + "http://test/arcs/arc1")) + (is (= (length (d:psis arc2)))) + (is (string= (d:uri (first (d:psis arc2))) + "http://test/arcs/arc2")) + (is (= (length (d:psis arc3)))) + (is (string= (d:uri (first (d:psis arc3))) + "http://test/arcs/arc3")) + (is (= (length (d:psis arc4)))) + (is (string= (d:uri (first (d:psis arc4))) + "http://test/arcs/arc4")) + (is (= (length (d:used-as-type arc1)) 1)) + (is (eql (reifier (first (d:used-as-type arc1))) reification-1)) + (is (eql (reified reification-1) (first (d:used-as-type arc1)))) + (is (eql (reifier (first (d:used-as-type arc3))) reification-2)) + (is (eql (reified reification-2) (first (d:used-as-type arc3)))))))) + (elephant:close-store)) + ;;TODO: check rdf importer -;;TODO: check fragment exporter +;;TODO: check rdf exporter +;;TODO: check rdf-tm-reification-mapping ;;TODO: check merge-reifier-topics (--> versioning) +;;TODO: check fragment exporter ;;TODO: extend the fragment-importer in the RESTful-interface @@ -524,4 +640,5 @@ (it.bese.fiveam:run! 'test-xtm1.0-reification) (it.bese.fiveam:run! 'test-xtm2.0-reification) (it.bese.fiveam:run! 'test-xtm1.0-reification-exporter) - (it.bese.fiveam:run! 'test-xtm2.0-reification-exporter)) \ No newline at end of file + (it.bese.fiveam:run! 'test-xtm2.0-reification-exporter) + (it.bese.fiveam:run! 'test-rdf-importer-reification)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Thu Nov 26 05:40:44 2009 @@ -354,10 +354,10 @@ :player super-top) (list :instance-of role-type-2 :player sub-top)))) - (when reifier-id - (make-reification reifier-id sub-top super-top - assoc-type start-revision tm - :document-id document-id)) + ;(when reifier-id + ;(make-reification reifier-id sub-top super-top + ; assoc-type start-revision tm + ; :document-id document-id)) (let ((assoc (add-to-topicmap tm @@ -365,6 +365,9 @@ :start-revision start-revision :instance-of assoc-type :roles a-roles)))) + (when reifier-id + (make-reification reifier-id assoc start-revision tm + :document-id document-id)) (format t "a") assoc))))) @@ -396,10 +399,10 @@ :player type-top) (list :instance-of roletype-2 :player instance-top)))) - (when reifier-id - (make-reification reifier-id instance-top type-top - assoc-type start-revision tm - :document-id document-id)) + ;(when reifier-id + ; (make-reification reifier-id instance-top type-top + ; assoc-type start-revision tm + ; :document-id document-id)) (let ((assoc (add-to-topicmap tm @@ -407,6 +410,9 @@ :start-revision start-revision :instance-of assoc-type :roles a-roles)))) + (when reifier-id + (make-reification reifier-id assoc start-revision tm + :document-id document-id)) (format t "a") assoc))))) @@ -503,14 +509,17 @@ :player player-1) (list :instance-of role-type-2 :player top)))) - (when ID - (make-reification ID top player-1 type-top start-revision - tm :document-id document-id)) + ;(when ID + ; (make-reification ID top player-1 type-top start-revision + ; tm :document-id document-id)) (let ((assoc (add-to-topicmap tm (make-construct 'AssociationC :start-revision start-revision :instance-of type-top :roles roles)))) + (when ID + (make-reification ID assoc start-revision tm + :document-id document-id)) (format t "a") assoc)))))) @@ -542,43 +551,52 @@ assoc))))) -(defun make-reification (reifier-id subject object predicate start-revision tm - &key document-id) - "Creates a reification construct." + +(defun make-reification(reifier-id reifiable-construct start-revision tm &key (document-id *document-id*)) (declare (string reifier-id)) - (declare ((or OccurrenceC TopicC) object)) - (declare (TopicC subject predicate)) + (declare (ReifiableConstructC reifiable-construct)) (declare (TopicMapC tm)) - (elephant:ensure-transaction (:txn-nosync t) - (let ((reifier (make-topic-stub reifier-id nil nil nil start-revision tm - :document-id document-id)) - (predicate-arc (make-topic-stub *rdf-predicate* nil nil nil - start-revision - tm :document-id document-id)) - (object-arc (make-topic-stub *rdf-object* nil nil nil start-revision - tm :document-id document-id)) - (subject-arc (make-topic-stub *rdf-subject* nil nil nil - start-revision - tm :document-id document-id)) - (statement (make-topic-stub *rdf-statement* nil nil nil start-revision - tm :document-id document-id))) - (make-instance-of-association reifier statement nil start-revision tm - :document-id document-id) - (make-association-with-nodes reifier subject subject-arc tm - start-revision :document-id document-id) - (make-association-with-nodes reifier predicate predicate-arc - tm start-revision :document-id document-id) - (if (typep object 'd:TopicC) - (make-association-with-nodes reifier object object-arc - tm start-revision - :document-id document-id) - (make-construct 'd:OccurrenceC - :start-revision start-revision - :topic reifier - :themes (themes object) - :instance-of (instance-of object) - :charvalue (charvalue object) - :datatype (datatype object)))))) + (let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm + :document-id document-id))) + (add-reifier reifiable-construct reifier-topic))) + +;(defun make-reification (reifier-id subject object predicate start-revision tm +; &key document-id) +; "Creates a reification construct." +; (declare (string reifier-id)) +; (declare ((or OccurrenceC TopicC) object)) +; (declare (TopicC subject predicate)) +; (declare (TopicMapC tm)) +; (elephant:ensure-transaction (:txn-nosync t) +; (let ((reifier (make-topic-stub reifier-id nil nil nil start-revision tm +; :document-id document-id)) +; (predicate-arc (make-topic-stub *rdf-predicate* nil nil nil +; start-revision +; tm :document-id document-id)) +; (object-arc (make-topic-stub *rdf-object* nil nil nil start-revision +; tm :document-id document-id)) +; (subject-arc (make-topic-stub *rdf-subject* nil nil nil +; start-revision +; tm :document-id document-id)) +; (statement (make-topic-stub *rdf-statement* nil nil nil start-revision +; tm :document-id document-id))) +; (make-instance-of-association reifier statement nil start-revision tm +; :document-id document-id) +; (make-association-with-nodes reifier subject subject-arc tm +; start-revision :document-id document-id) +; (make-association-with-nodes reifier predicate predicate-arc +; tm start-revision :document-id document-id) +; (if (typep object 'd:TopicC) +; (make-association-with-nodes reifier object object-arc +; tm start-revision +; :document-id document-id) +; (make-construct 'd:OccurrenceC +; :start-revision start-revision +; :topic reifier +; :themes (themes object) +; :instance-of (instance-of object) +; :charvalue (charvalue object) +; :datatype (datatype object)))))) (defun make-occurrence (top literal start-revision tm-id @@ -610,8 +628,10 @@ :charvalue value :datatype datatype))) (when ID - (make-reification ID top occurrence type-top start-revision - xml-importer::tm :document-id document-id)) + ;(make-reification ID top occurrence type-top start-revision + ; xml-importer::tm :document-id document-id)) + (make-reification ID occurrence start-revision xml-importer::tm + :document-id document-id)) occurrence))))))