isidorus-cvs
Threads by month
- ----- 2025 -----
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- 1037 discussions
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
1
0
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))
1
0
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)))
1
0
Author: lgiessmann
Date: Thu Sep 10 06:12:47 2009
New Revision: 141
Log:
datamodel: added a 1:1 elephant-assocation to ReifiableConstructC and TopicC realizing reification; extended the functions delete-construct and initialize-instance of the affected classes
Modified:
trunk/src/model/datamodel.lisp
trunk/src/unit_tests/importer_test.lisp
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Thu Sep 10 06:12:47 2009
@@ -101,6 +101,8 @@
:variants
:xor
:create-latest-fragment-of-topic
+ :reified
+ :reifier
:*current-xtm* ;; special variables
:*TM-REVISION*
@@ -372,11 +374,11 @@
(symbol-value '*TM-REVISION*))
(t 0)))
(properties (slot-value construct slot-name)))
- ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision)
+ ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision)
(cond
((not properties)
nil) ;if we don't have any properties, we don't have to worry
- ;about revisions
+ ;about revisions
((= 0 revision)
(remove
nil
@@ -599,26 +601,45 @@
:inherit t
:documentation "Slot that realizes a 1 to N
relation between reifiable constructs and their
- identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs"))
+ identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")
+ (reifier
+ :associate TopicC
+ :inherit t
+ :documentation "Represents a reifier association to a topic, i.e.
+ it stands for a 1:1 association between this class and TopicC"))
(:documentation "Reifiable constructs as per TMDM"))
+
+(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))))
+
+(defgeneric (setf reifier) (topic TopicC)
+ (:method (topic (construct ReifiableConstructC))
+ (setf (slot-value construct 'reifier) topic)
+ (setf (reified topic) construct)))
+
(defgeneric item-identifiers (construct &key revision)
(:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision construct 'item-identifiers :start-revision revision)))
-(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil))
+(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil))
"adds associations to these ids after the instance was initialized."
(declare (list item-identifiers))
(call-next-method)
(dolist (id item-identifiers)
(declare (ItemIdentifierC id))
(setf (identified-construct id) instance))
+ (when reifier
+ (setf (reifier instance) reifier))
instance)
-
(defmethod delete-construct :before ((construct ReifiableConstructC))
(dolist (id (item-identifiers construct))
- (delete-construct id)))
+ (delete-construct id))
+ (when (reifier construct)
+ (slot-makunbound (reifier construct) 'reified)))
(defgeneric item-identifiers-p (constr)
(:documentation "Test for the existence of item identifiers")
@@ -928,9 +949,23 @@
(in-topicmaps
:associate (TopicMapC topics)
:many-to-many t
- :documentation "list of all topic maps this topic is part of"))
+ :documentation "list of all topic maps this topic is part of")
+ (reified
+ :associate ReifiableConstructC
+ :documentation "contains a reified object, represented as 1:1 association"))
(:documentation "Topic in a Topic Map"))
+
+(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))))
+
+(defgeneric (setf reified) (reifiable ReifiableConstructC)
+ (:method (reifiable (topic TopicC))
+ (setf (slot-value topic 'reified) reifiable)
+ (setf (reifier reifiable) topic)))
+
(defgeneric occurrences (topic &key revision)
(:method ((topic TopicC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision topic 'occurrences :start-revision revision)))
@@ -966,19 +1001,21 @@
(:method ((topic TopicC) &key (revision *TM-REVISION*))
(filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)))
-(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil))
+(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))
(declare (list locators))
(call-next-method)
- ;item-identifiers are handled in the around-method for ReifiableConstructs,
- ;TopicIdentificationCs are handled in make-construct of TopicC
+ ;item-identifiers are handled in the around-method for ReifiableConstructs,
+ ;TopicIdentificationCs are handled in make-construct of TopicC
(dolist (persistent-id psis)
(declare (PersistentIdC persistent-id))
(setf (identified-construct persistent-id) instance))
(dolist (subject-locator locators)
(declare (SubjectLocatorC subject-locator))
- (setf (identified-construct subject-locator) instance)))
+ (setf (identified-construct subject-locator) instance))
+ (when reified
+ (setf (reified instance) reified)))
(defmethod delete-construct :before ((construct TopicC))
@@ -993,7 +1030,9 @@
(dolist (theme (used-as-theme construct))
(elephant:remove-association construct 'used-as-theme theme))
(dolist (tm (in-topicmaps construct))
- (elephant:remove-association construct 'in-topicmaps tm)))
+ (elephant:remove-association construct 'in-topicmaps tm))
+ (when (reified construct)
+ (slot-makunbound (reified construct) 'reifier)))
(defun get-all-constructs-by-uri (uri)
(delete
Modified: trunk/src/unit_tests/importer_test.lisp
==============================================================================
--- trunk/src/unit_tests/importer_test.lisp (original)
+++ trunk/src/unit_tests/importer_test.lisp Thu Sep 10 06:12:47 2009
@@ -662,6 +662,5 @@
;as (importer-test:run-importer-tests)
(defun run-importer-tests ()
(run! 'importer-test))
-;or (it.bese.fiveam.run! )
1
0
Author: lgiessmann
Date: Wed Sep 9 03:56:23 2009
New Revision: 140
Log:
unit-tests: added functions of the for run-<module-name>-tests to all unit-tests without such a function -> consiteny
Modified:
trunk/src/unit_tests/atom_test.lisp
trunk/src/unit_tests/versions_test.lisp
Modified: trunk/src/unit_tests/atom_test.lisp
==============================================================================
--- trunk/src/unit_tests/atom_test.lisp (original)
+++ trunk/src/unit_tests/atom_test.lisp Wed Sep 9 03:56:23 2009
@@ -28,7 +28,9 @@
duplicate-identifier-error)
(:export :atom-test
:test-feed-to-string
- :test-collection-configuration))
+ :test-collection-configuration
+ :test-changes-feeds
+ :run-atom-tests))
;test configuration
(in-package :atom-test)
@@ -204,3 +206,8 @@
(mapcar #'type-of collection-entries)))
)))
+
+(defun run-atom-tests()
+ (it.bese.fiveam:run! 'test-feed-to-string)
+ (it.bese.fiveam:run! 'test-changes-feeds)
+ (it.bese.fiveam:run! 'test-collection-configuration))
\ No newline at end of file
Modified: trunk/src/unit_tests/versions_test.lisp
==============================================================================
--- trunk/src/unit_tests/versions_test.lisp (original)
+++ trunk/src/unit_tests/versions_test.lisp Wed Sep 9 03:56:23 2009
@@ -32,7 +32,7 @@
:test-change-lists
:test-changed-p
:versions-test
- ))
+ :run-versions-tests))
(declaim (optimize (debug 3)))
(in-package :versions-test)
@@ -363,4 +363,12 @@
:revision (1+ fixtures::revision3))))))
-
\ No newline at end of file
+
+(defun run-versions-tests()
+ (it.bese.fiveam:run! 'test-get-item-by-id-t100)
+ (it.bese.fiveam:run! 'test-get-item-by-id-t301)
+ (it.bese.fiveam:run! 'test-norwegian-curriculum-association)
+ (it.bese.fiveam:run! 'test-instance-of-t64)
+ (it.bese.fiveam:run! 'test-change-lists)
+ (it.bese.fiveam:run! 'test-changed-p)
+ (it.bese.fiveam:run! 'test-mark-as-deleted))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Wed Sep 9 03:42:00 2009
New Revision: 139
Log:
rdf-importer: fixed a bug with xml:base and xml:lang; renamed some parameters for a better understanding
Modified:
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Wed Sep 9 03:42:00 2009
@@ -84,31 +84,36 @@
(let ((children (child-nodes-or-text rdf-dom :trim t)))
(when children
(loop for child across children
- do (import-node child tm-id start-revision :document-id document-id
- :xml-base xml-base :xml-lang xml-lang))))
- (import-node rdf-dom tm-id start-revision :document-id document-id
- :xml-base xml-base :xml-lang xml-lang)))
+ do (import-node child tm-id start-revision
+ :document-id document-id
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))
+ (import-node rdf-dom tm-id start-revision
+ :document-id document-id
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang)))
(setf *_n-map* nil))
(defun import-node (elem tm-id start-revision &key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
+ "Imports an RDF node with all its properties and 'child' RDF nodes."
(tm-id-p tm-id "import-node")
(parse-node elem)
- (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
- (let ((about (get-absolute-attribute elem tm-id xml-base "about"))
- (nodeID (get-ns-attribute elem "nodeID"))
- (ID (get-absolute-attribute elem tm-id xml-base "ID"))
- (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
- (parse-properties-of-node elem (or about nodeID ID UUID))
-
- (let ((literals (append (get-literals-of-node elem fn-xml-lang)
+ (let ((about (get-absolute-attribute elem tm-id parent-xml-base "about"))
+ (nodeID (get-ns-attribute elem "nodeID"))
+ (ID (get-absolute-attribute elem tm-id parent-xml-base "ID"))
+ (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
+ (parse-properties-of-node elem (or about nodeID ID UUID))
+ (let ((literals (append (get-literals-of-node elem parent-xml-lang)
(get-literals-of-node-content
- elem tm-id xml-base fn-xml-lang)))
- (associations (get-associations-of-node-content elem tm-id xml-base))
- (types (get-types-of-node elem tm-id :parent-xml-base xml-base))
+ elem tm-id parent-xml-base parent-xml-lang)))
+ (associations (get-associations-of-node-content elem tm-id
+ parent-xml-base))
+ (types (get-types-of-node elem tm-id
+ :parent-xml-base parent-xml-base))
(super-classes
- (get-super-classes-of-node-content elem tm-id xml-base)))
+ (get-super-classes-of-node-content elem tm-id parent-xml-base)))
(with-tm (start-revision document-id tm-id)
(let ((this
(make-topic-stub
@@ -124,19 +129,18 @@
start-revision :document-id document-id)
(make-recursion-from-node elem tm-id start-revision
:document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang)
- this))))))
+ :parent-xml-base parent-xml-base
+ :parent-xml-lang parent-xml-lang)
+ this)))))
(defun import-arc (elem tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Imports a property that is an blank_node and continues the recursion
on this element."
(declare (dom:element elem))
- (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
- (fn-xml-base (get-xml-base elem :old-base xml-base))
+ (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang))
(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
(parseType (get-ns-attribute elem "parseType"))
(content (child-nodes-or-text elem :trim t)))
@@ -156,24 +160,26 @@
:revision start-revision)))
(let ((literals
(append (get-literals-of-property
- elem fn-xml-lang)
+ elem xml-lang)
(get-literals-of-node-content
- elem tm-id xml-base fn-xml-lang)))
+ elem tm-id parent-xml-base
+ parent-xml-lang)))
(associations
(get-associations-of-node-content
- elem tm-id xml-base))
+ elem tm-id parent-xml-base))
(types
(remove-if
#'null
(append
- (get-types-of-node-content elem tm-id fn-xml-base)
+ (get-types-of-node-content elem tm-id
+ parent-xml-base)
(when (get-ns-attribute elem "type")
(list :ID nil
:topicid (get-ns-attribute elem "type")
:psi (get-ns-attribute elem "type"))))))
(super-classes
(get-super-classes-of-node-content
- elem tm-id xml-base)))
+ elem tm-id parent-xml-base)))
(make-literals this literals tm-id start-revision
:document-id document-id)
(make-associations this associations xml-importer::tm
@@ -186,19 +192,20 @@
this)))))
(make-recursion-from-arc elem tm-id start-revision
:document-id document-id
- :xml-base xml-base :xml-lang xml-lang)
+ :parent-xml-base parent-xml-base
+ :parent-xml-lang parent-xml-lang)
this-topic)))))
(defun make-collection (elem tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Creates a collection structure of a node that contains
parseType='Collection."
(declare (dom:element elem))
(with-tm (start-revision document-id tm-id)
- (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
- (fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base))
+ (xml-lang (get-xml-lang elem :old-lang parent-xml-lang))
(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
(let ((this (make-topic-stub nil nil nil UUID start-revision
xml-importer::tm
@@ -206,8 +213,8 @@
(items (loop for item across (child-nodes-or-text elem :trim t)
collect (import-node item tm-id start-revision
:document-id document-id
- :xml-base fn-xml-base
- :xml-lang fn-xml-lang))))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))
(let ((last-blank-node this))
(dotimes (index (length items))
(let ((is-end
@@ -466,10 +473,6 @@
(when lang
(let ((psi-and-topic-id
(concatenate-uri *rdf2tm-scope-prefix* lang)))
- ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id
-; :revision start-revision)))
-; (if top
-; top
(make-topic-stub psi-and-topic-id nil nil nil start-revision
tm :document-id document-id))))
@@ -612,13 +615,13 @@
occurrence))))))
-(defun get-literals-of-node-content (node tm-id xml-base xml-lang)
+(defun get-literals-of-node-content (node tm-id parent-xml-base parent-xml-lang)
"Returns a list of literals that is produced of a node's content."
(declare (dom:element node))
(tm-id-p tm-id "get-literals-of-noode-content")
(let ((properties (child-nodes-or-text node :trim t))
- (fn-xml-base (get-xml-base node :old-base xml-base))
- (fn-xml-lang (get-xml-lang node :old-lang xml-lang)))
+ (xml-base (get-xml-base node :old-base parent-xml-base))
+ (xml-lang (get-xml-lang node :old-lang parent-xml-lang)))
(let ((literals
(when properties
(loop for property across properties
@@ -643,11 +646,11 @@
(string/= parseType "Resource")))
collect (let ((content (child-nodes-or-text property))
(ID (get-absolute-attribute property tm-id
- fn-xml-base "ID"))
+ xml-base "ID"))
(child-xml-lang
- (get-xml-lang property :old-lang fn-xml-lang)))
+ (get-xml-lang property :old-lang xml-lang)))
(let ((full-name (get-type-of-node-name property))
- (datatype (get-datatype property tm-id fn-xml-base))
+ (datatype (get-datatype property tm-id xml-base))
(text
(cond
((= (length content) 0)
@@ -670,18 +673,18 @@
literals)))
-(defun get-types-of-node-content (node tm-id xml-base)
+(defun get-types-of-node-content (node tm-id parent-xml-base)
"Returns a list of type-uris that corresponds to the node's content
or attributes."
(tm-id-p tm-id "get-types-of-node-content")
- (let ((fn-xml-base (get-xml-base node :old-base xml-base)))
+ (let ((xml-base (get-xml-base node :old-base parent-xml-base)))
(let ((attr-type
(if (get-ns-attribute node "type")
(list
(list :topicid (absolutize-value (get-ns-attribute node "type")
- fn-xml-base tm-id)
+ xml-base tm-id)
:psi (absolutize-value (get-ns-attribute node "type")
- fn-xml-base tm-id)
+ xml-base tm-id)
:ID nil))
nil))
(content-types
@@ -691,17 +694,17 @@
(string= (get-node-name child) "type"))
collect (let ((nodeID (get-ns-attribute child "nodeID"))
(resource (get-absolute-attribute
- child tm-id fn-xml-base "resource"))
+ child tm-id xml-base "resource"))
(UUID (get-ns-attribute child "UUID"
:ns-uri *rdf2tm-ns*))
(ID (get-absolute-attribute child tm-id
- fn-xml-base "ID")))
+ xml-base "ID")))
(if (or nodeID resource UUID)
(list :topicid (or nodeID resource UUID)
:psi resource
:ID ID)
(let ((child-xml-base
- (get-xml-base child :old-base fn-xml-base)))
+ (get-xml-base child :old-base xml-base)))
(let ((refs
(get-node-refs
(child-nodes-or-text child :trim t)
@@ -712,9 +715,9 @@
(remove-if #'null (append attr-type content-types)))))
-(defun get-literals-of-property (property xml-lang)
+(defun get-literals-of-property (property parent-xml-lang)
"Returns a list of attributes that are treated as literal nodes."
- (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang))
+ (let ((xml-lang (get-xml-lang property :old-lang parent-xml-lang))
(attributes nil))
(dom:map-node-map
#'(lambda(attr)
@@ -737,7 +740,7 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))
((or (string= attr-ns *xml-ns*)
@@ -749,16 +752,16 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))))))
(dom:attributes property))
attributes))
-(defun get-literals-of-node (node xml-lang)
+(defun get-literals-of-node (node parent-xml-lang)
"Returns alist of attributes that are treated as literal nodes."
- (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang))
+ (let ((xml-lang (get-xml-lang node :old-lang parent-xml-lang))
(attributes nil))
(dom:map-node-map
#'(lambda(attr)
@@ -777,7 +780,7 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))
((or (string= attr-ns *xml-ns*)
@@ -789,19 +792,19 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))))))
(dom:attributes node))
attributes))
-(defun get-super-classes-of-node-content (node tm-id xml-base)
+(defun get-super-classes-of-node-content (node tm-id parent-xml-base)
"Returns a list of super-classes and IDs."
(declare (dom:element node))
(tm-id-p tm-id "get-super-classes-of-node-content")
(let ((content (child-nodes-or-text node :trim t))
- (fn-xml-base (get-xml-base node :old-base xml-base)))
+ (xml-base (get-xml-base node :old-base parent-xml-base)))
(when content
(loop for property across content
when (let ((prop-name (get-node-name property))
@@ -809,13 +812,13 @@
(and (string= prop-name "subClassOf")
(string= prop-ns *rdfs-ns*)))
collect (let ((prop-xml-base (get-xml-base property
- :old-base fn-xml-base)))
+ :old-base xml-base)))
(let ((ID (get-absolute-attribute property tm-id
- fn-xml-base "ID"))
+ xml-base "ID"))
(nodeID (get-ns-attribute property "nodeID"))
(resource
(get-absolute-attribute property tm-id
- fn-xml-base "resource"))
+ xml-base "resource"))
(UUID (get-ns-attribute property "UUID"
:ns-uri *rdf2tm-ns*)))
(if (or nodeID resource UUID)
@@ -830,17 +833,17 @@
:ID ID)))))))))
-(defun get-associations-of-node-content (node tm-id xml-base)
+(defun get-associations-of-node-content (node tm-id parent-xml-base)
"Returns a list of associations with a type, value and ID member."
(declare (dom:element node))
(let ((properties (child-nodes-or-text node :trim t))
- (fn-xml-base (get-xml-base node :old-base xml-base)))
+ (xml-base (get-xml-base node :old-base parent-xml-base)))
(loop for property across properties
when (let ((prop-name (get-node-name property))
(prop-ns (dom:namespace-uri property))
(prop-content (child-nodes-or-text property))
(resource (get-absolute-attribute property tm-id
- fn-xml-base "resource"))
+ xml-base "resource"))
(nodeID (get-ns-attribute property "nodeID"))
(type (get-ns-attribute property "type"))
(parseType (get-ns-attribute property "parseType"))
@@ -858,7 +861,7 @@
(not (and (string= prop-name "subClassOf")
(string= prop-ns *rdfs-ns*)))))
collect (let ((prop-xml-base (get-xml-base property
- :old-base fn-xml-base))
+ :old-base xml-base))
(content (child-nodes-or-text property :trim t))
(parseType (get-ns-attribute property "parseType")))
(let ((resource
@@ -866,12 +869,12 @@
(= (length content) 0))
*rdf-nil*
(get-absolute-attribute property tm-id
- fn-xml-base "resource")))
+ xml-base "resource")))
(nodeID (get-ns-attribute property "nodeID"))
(UUID (get-ns-attribute property "UUID"
:ns-uri *rdf2tm-ns*))
(ID (get-absolute-attribute property tm-id
- fn-xml-base "ID"))
+ xml-base "ID"))
(full-name (get-type-of-node-name property)))
(if (or nodeID resource UUID)
(list :type full-name
@@ -889,42 +892,45 @@
(defun make-recursion-from-node (node tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Calls the next function that handles all DOM child elements
of the passed element as arcs."
(declare (dom:element node))
(let ((content (child-nodes-or-text node :trim t))
(err-pref "From make-recursion-from-node(): ")
- (fn-xml-base (get-xml-base node :old-base xml-base))
- (fn-xml-lang (get-xml-lang node :old-lang xml-lang)))
+ (xml-base (get-xml-base node :old-base parent-xml-base))
+ (xml-lang (get-xml-lang node :old-lang parent-xml-lang)))
(when (stringp content)
(error "~aliteral content not allowed here: ~a"
err-pref content))
(loop for arc across content
collect (import-arc arc tm-id start-revision :document-id document-id
- :xml-base fn-xml-base :xml-lang fn-xml-lang))))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))
(defun make-recursion-from-arc (arc tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Calls the next function that handles the arcs content nodes/arcs."
(declare (dom:element arc))
- (let ((fn-xml-base (get-xml-base arc :old-base xml-base))
- (fn-xml-lang (get-xml-lang arc :old-lang xml-lang))
+ (let ((xml-base (get-xml-base arc :old-base parent-xml-base))
+ (xml-lang (get-xml-lang arc :old-lang parent-xml-lang))
(content (child-nodes-or-text arc))
(parseType (get-ns-attribute arc "parseType")))
- (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype"))
- (type (get-absolute-attribute arc tm-id xml-base "type"))
- (resource (get-absolute-attribute arc tm-id xml-base "resource"))
+ (let ((datatype (get-absolute-attribute arc tm-id
+ parent-xml-base "datatype"))
+ (type (get-absolute-attribute arc tm-id parent-xml-base "type"))
+ (resource (get-absolute-attribute arc tm-id
+ parent-xml-base "resource"))
(nodeID (get-ns-attribute arc "nodeID"))
- (literals (get-literals-of-property arc xml-lang)))
+ (literals (get-literals-of-property arc parent-xml-lang)))
(if (and parseType
(string= parseType "Collection"))
(make-collection arc tm-id start-revision
:document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang)
+ :parent-xml-base parent-xml-base
+ :parent-xml-lang parent-xml-lang)
(if (or datatype resource nodeID
(and parseType
(string= parseType "Literal"))
@@ -938,10 +944,10 @@
(loop for item across content
collect (import-arc item tm-id start-revision
:document-id document-id
- :xml-base fn-xml-base
- :xml-lang fn-xml-lang))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))
(loop for item across content
collect (import-node item tm-id start-revision
:document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang))))))))
\ No newline at end of file
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))))))
\ No newline at end of file
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 9 03:42:00 2009
@@ -282,21 +282,21 @@
t)
-(defun get-node-refs (nodes tm-id xml-base)
+(defun get-node-refs (nodes tm-id parent-xml-base)
"Returns a list of node references that can be used as topic IDs."
(when (and nodes
(> (length nodes) 0))
(loop for node across nodes
- collect (let ((fn-xml-base (get-xml-base node :old-base xml-base)))
+ collect (let ((xml-base (get-xml-base node :old-base parent-xml-base)))
(parse-node node)
(let ((ID (when (get-ns-attribute node "ID")
(absolutize-id (get-ns-attribute node "ID")
- fn-xml-base tm-id)))
+ xml-base tm-id)))
(nodeID (get-ns-attribute node "nodeID"))
(about (when (get-ns-attribute node "about")
(absolutize-value
(get-ns-attribute node "about")
- fn-xml-base tm-id)))
+ xml-base tm-id)))
(UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)))
(list :topicid (or ID about nodeID UUID)
:psi (or ID about)))))))
@@ -465,29 +465,28 @@
t)
-(defun get-absolute-attribute (elem tm-id xml-base attr-name
+(defun get-absolute-attribute (elem tm-id parent-xml-base attr-name
&key (ns-uri *rdf-ns*))
"Returns an absolute 'attribute' or nil."
(declare (dom:element elem))
(declare (string attr-name))
(tm-id-p tm-id "get-ID")
(let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri))
- (fn-xml-base (get-xml-base elem :old-base xml-base)))
+ (xml-base (get-xml-base elem :old-base parent-xml-base)))
(when attr
(if (and (string= ns-uri *rdf-ns*)
(string= attr-name "ID"))
- (absolutize-id attr fn-xml-base tm-id)
- (absolutize-value attr fn-xml-base tm-id)))))
+ (absolutize-id attr xml-base tm-id)
+ (absolutize-value attr xml-base tm-id)))))
-(defun get-datatype (elem tm-id xml-base)
+(defun get-datatype (elem tm-id parent-xml-base)
"Returns a datatype value. The default is xml:string."
- (let ((fn-xml-base (get-xml-base elem :old-base xml-base)))
- (let ((datatype
- (get-absolute-attribute elem tm-id fn-xml-base "datatype")))
- (if datatype
- datatype
- *xml-string*))))
+ (let ((datatype
+ (get-absolute-attribute elem tm-id parent-xml-base "datatype")))
+ (if datatype
+ datatype
+ *xml-string*)))
(defun tm-id-p (tm-id fun-name)
@@ -500,14 +499,13 @@
(defun get-types-of-node (elem tm-id &key (parent-xml-base nil))
"Returns a plist of all node's types of the form
(:topicid <string> :psi <string> :ID <string>)."
- (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
- (remove-if
- #'null
- (append (unless (string= (get-type-of-node-name elem)
- (concatenate 'string *rdf-ns*
- "Description"))
- (list
- (list :topicid (get-type-of-node-name elem)
- :psi (get-type-of-node-name elem)
- :ID nil)))
- (get-types-of-node-content elem tm-id xml-base)))))
\ No newline at end of file
+ (remove-if
+ #'null
+ (append (unless (string= (get-type-of-node-name elem)
+ (concatenate 'string *rdf-ns*
+ "Description"))
+ (list
+ (list :topicid (get-type-of-node-name elem)
+ :psi (get-type-of-node-name elem)
+ :ID nil)))
+ (get-types-of-node-content elem tm-id parent-xml-base))))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Tue Sep 8 09:37:26 2009
New Revision: 138
Log:
rdf-importer: fixed a bug when importing rdf-isidorus-names without nametypes.
Modified:
trunk/src/xml/rdf/map_to_tm.lisp
Modified: trunk/src/xml/rdf/map_to_tm.lisp
==============================================================================
--- trunk/src/xml/rdf/map_to_tm.lisp (original)
+++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 09:37:26 2009
@@ -277,8 +277,7 @@
"Maps the passed occurrence-topic to a TM occurrence."
(declare (TopicC top name-top))
(declare (integer start-revision))
- (let ((err-pref "From map-isi-name(): ")
- (ids (map-isi-identifiers name-top start-revision))
+ (let ((ids (map-isi-identifiers name-top start-revision))
(type-assocs
(get-associations-by-type
name-top start-revision *tm2rdf-nametype-property*
@@ -290,8 +289,11 @@
(value-type-topic
(get-item-by-psi *tm2rdf-value-property*))
(variant-topics (get-isi-variants name-top start-revision)))
- (let ((types (get-players-by-role-type
- type-assocs start-revision *rdf2tm-object*))
+ (let ((types (let ((fn-types
+ (get-players-by-role-type
+ type-assocs start-revision *rdf2tm-object*)))
+ (when fn-types
+ (first fn-types))))
(scopes (get-players-by-role-type
scope-assocs start-revision *rdf2tm-object*))
(value
@@ -305,14 +307,11 @@
(elephant:ensure-transaction (:txn-nosync t)
(map 'list #'d::delete-construct type-assocs)
(map 'list #'d::delete-construct scope-assocs)
- (when (/= 1 (length types))
- (error "~aexpect one type topic but found: ~a (~a)"
- err-pref (length types) value))
(let ((name (make-construct 'NameC
:start-revision start-revision
:topic top
:charvalue value
- :instance-of (first types)
+ :instance-of types
:item-identifiers ids
:themes scopes)))
(map 'list #'(lambda(variant-top)
1
0
Author: lgiessmann
Date: Tue Sep 8 06:54:19 2009
New Revision: 137
Log:
rdf-importer: added some unit-tests
Modified:
trunk/src/unit_tests/full_mapping.rdf
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/unit_tests/unittests-constants.lisp
Modified: trunk/src/unit_tests/full_mapping.rdf
==============================================================================
--- trunk/src/unit_tests/full_mapping.rdf (original)
+++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 06:54:19 2009
@@ -31,7 +31,7 @@
</rdf:Description>
- <rdf:Description rdf:nodeID="id_285">
+ <rdf:Description rdf:nodeID="id_283">
<isi:variant rdf:parseType="Resource">
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/>
<isi:scope rdf:resource="http://simpsons/display"/>
@@ -121,13 +121,13 @@
<isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity>
</rdf:Description>
- <rdf:Description>
+ <rdf:Description rdf:nodeID="id_291">
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/>
<isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity>
<isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-2</isi:itemIdentity>
<isi:associationtype rdf:resource="http://simpsons/married"/>
<isi:role>
- <rdf:Description>
+ <rdf:Description rdf:nodeID="id_295">
<isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity>
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
<isi:roletype rdf:resource="http://simpsons/wife"/>
@@ -135,7 +135,7 @@
</rdf:Description>
</isi:role>
<isi:role>
- <rdf:Description>
+ <rdf:Description rdf:nodeID="id_292">
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
<isi:roletype rdf:resource="http://simpsons/husband"/>
<isi:player rdf:resource="http://simpsons/homer"/>
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 Tue Sep 8 06:54:19 2009
@@ -66,7 +66,10 @@
:test-poems-rdf-topics
:test-empty-collection
:test-collection
- :test-xml-base))
+ :test-xml-base
+ :test-full-mapping-marge
+ :test-full-mapping-homer
+ :test-full-mapping-association))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -79,6 +82,14 @@
(in-suite rdf-importer-test)
+(defun empty-p (top)
+ (declare (TopicC top))
+ (and (not (d:item-identifiers top))
+ (not (d:locators top))
+ (not (d:names top))
+ (not (d:occurrences top))))
+
+
(test test-get-literals-of-node
"Tests the helper function get-literals-of-node."
(let ((doc-1
@@ -3060,6 +3071,306 @@
"/test")
"http://base-3/test")))))))
+
+(test test-full-mapping-marge
+ "Tests the entire importer module."
+ (let ((dir "data_base")
+ (rdf-file unittests-constants:*full_mapping.rdf*)
+ (tm-id "http://full-mapping/")
+ (document-id "http://full_mapping.rdf"))
+ (when elephant:*store-controller*
+ (elephant:close-store))
+ (fixtures::clean-out-db dir)
+ (rdf-importer:rdf-importer rdf-file dir
+ :tm-id tm-id
+ :document-id document-id)
+ (elephant:open-store (xml-importer:get-store-spec dir))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15))
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1))
+ (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4))
+ (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2))
+ (setf d:*current-xtm* document-id)
+ (let ((firstName (get-item-by-id "http://simpsons/firstName"))
+ (lastName (get-item-by-id "http://simpsons/lastName"))
+ (display (get-item-by-id "http://simpsons/display"))
+ (profession (get-item-by-id "http://simpsons/profession"))
+ (married (get-item-by-id "http://simpsons/married"))
+ (husband (get-item-by-id "http://simpsons/husband"))
+ (wife (get-item-by-id "http://simpsons/wife"))
+ (en (get-item-by-id "http://simpsons/en"))
+ (type (get-item-by-psi *type-psi*))
+ (instance (get-item-by-psi *instance-psi*))
+ (type-instance (get-item-by-psi *type-instance-psi*))
+ (isi-object (get-item-by-psi *rdf2tm-object*))
+ (isi-subject (get-item-by-psi *rdf2tm-subject*))
+ (marge (get-item-by-id "http://simpsons/marge"))
+ (homer (get-item-by-id "http://simpsons/homer"))
+ (role-husband
+ (find-if #'(lambda(x)
+ (let ((iis (d:item-identifiers x)))
+ (when (= (length iis) 1)
+ (string= (d:uri (first iis))
+ "http://simpsons/role-husband/ii"))))
+ (elephant:get-instances-by-class 'd:RoleC)))
+ (role-wife
+ (find-if #'(lambda(x)
+ (let ((iis (d:item-identifiers x)))
+ (when (= (length iis) 1)
+ (string= (d:uri (first iis))
+ "http://simpsons/role-wife/ii"))))
+ (elephant:get-instances-by-class 'd:RoleC))))
+ (is-true firstName)
+ (is-true (empty-p firstName))
+ (is-true lastName)
+ (is-true (empty-p lastName))
+ (is-true display)
+ (is-true (empty-p display))
+ (is-true profession)
+ (is-true (empty-p profession))
+ (is-true married)
+ (is-true (empty-p married))
+ (is-true husband)
+ (is-true (empty-p husband))
+ (is-true wife)
+ (is-true (empty-p wife))
+ (is-true en)
+ (is-true (empty-p en))
+ (is-true type)
+ (is-true (empty-p type))
+ (is-true instance)
+ (is-true (empty-p instance))
+ (is-true type-instance)
+ (is-true (empty-p type-instance))
+ (is-true isi-object)
+ (is-true (empty-p isi-object))
+ (is-true isi-subject)
+ (is-true (empty-p isi-subject))
+ (is-true role-husband)
+ (is-true role-wife)
+ (is-true homer)
+ (is (= (length (d:psis marge)) 2))
+ (is-true (find-if #'(lambda(x)
+ (string= (d:uri x) "http://simpsons/marjorie"))
+ (d:psis marge)))
+ (is (= (length (d:names marge)) 2))
+ (let ((marge-fn (find-if #'(lambda(x)
+ (eql (instance-of x) firstName))
+ (d:names marge)))
+ (marge-ln (find-if #'(lambda(x)
+ (eql (instance-of x) lastName))
+ (d:names marge)))
+ (marge-occ (find-if #'(lambda(x)
+ (eql (instance-of x) profession))
+ (d:occurrences marge))))
+ (is-true marge-fn)
+ (is-true marge-ln)
+ (is (string= (d:charvalue marge-fn) "Marjorie"))
+ (is (string= (d:charvalue marge-ln) "Simpson"))
+ (is (= (length (d:variants marge-fn)) 1))
+ (is (= (length (d:themes (first (d:variants marge-fn)))) 1))
+ (is (eql (first (d:themes (first (d:variants marge-fn)))) display))
+ (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge"))
+ (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*))
+ (is-true marge-occ)
+ (is (string= (d:charvalue marge-occ) "Housewife"))
+ (is (string= (d:datatype marge-occ) *xml-string*))
+ (is (= (length (d:themes marge-occ)) 0))
+ (is (= (length (d:psis marge)) 2))))))
+
+
+(test test-full-mapping-homer
+ "Tests the entire importer module."
+ (let ((dir "data_base")
+ (rdf-file unittests-constants:*full_mapping.rdf*)
+ (tm-id "http://full-mapping/")
+ (document-id "http://full_mapping.rdf"))
+ (when elephant:*store-controller*
+ (elephant:close-store))
+ (fixtures::clean-out-db dir)
+ (rdf-importer:rdf-importer rdf-file dir
+ :tm-id tm-id
+ :document-id document-id)
+ (elephant:open-store (xml-importer:get-store-spec dir))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15))
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1))
+ (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4))
+ (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2))
+ (setf d:*current-xtm* document-id)
+ (let ((firstName (get-item-by-id "http://simpsons/firstName"))
+ (lastName (get-item-by-id "http://simpsons/lastName"))
+ (display (get-item-by-id "http://simpsons/display"))
+ (profession (get-item-by-id "http://simpsons/profession"))
+ (married (get-item-by-id "http://simpsons/married"))
+ (husband (get-item-by-id "http://simpsons/husband"))
+ (wife (get-item-by-id "http://simpsons/wife"))
+ (en (get-item-by-id "http://simpsons/en"))
+ (type (get-item-by-psi *type-psi*))
+ (instance (get-item-by-psi *instance-psi*))
+ (type-instance (get-item-by-psi *type-instance-psi*))
+ (isi-object (get-item-by-psi *rdf2tm-object*))
+ (isi-subject (get-item-by-psi *rdf2tm-subject*))
+ (marge (get-item-by-id "http://simpsons/marge"))
+ (homer (get-item-by-id "http://simpsons/homer"))
+ (role-husband
+ (find-if #'(lambda(x)
+ (let ((iis (d:item-identifiers x)))
+ (when (= (length iis) 1)
+ (string= (d:uri (first iis))
+ "http://simpsons/role-husband/ii"))))
+ (elephant:get-instances-by-class 'd:RoleC)))
+ (role-wife
+ (find-if #'(lambda(x)
+ (let ((iis (d:item-identifiers x)))
+ (when (= (length iis) 1)
+ (string= (d:uri (first iis))
+ "http://simpsons/role-wife/ii"))))
+ (elephant:get-instances-by-class 'd:RoleC))))
+ (is-true firstName)
+ (is-true (empty-p firstName))
+ (is-true lastName)
+ (is-true (empty-p lastName))
+ (is-true display)
+ (is-true (empty-p display))
+ (is-true profession)
+ (is-true (empty-p profession))
+ (is-true married)
+ (is-true (empty-p married))
+ (is-true husband)
+ (is-true (empty-p husband))
+ (is-true wife)
+ (is-true (empty-p wife))
+ (is-true en)
+ (is-true (empty-p en))
+ (is-true type)
+ (is-true (empty-p type))
+ (is-true instance)
+ (is-true (empty-p instance))
+ (is-true type-instance)
+ (is-true (empty-p type-instance))
+ (is-true isi-object)
+ (is-true (empty-p isi-object))
+ (is-true isi-subject)
+ (is-true (empty-p isi-subject))
+ (is-true role-husband)
+ (is-true role-wife)
+ (is-true marge)
+ (is-true (find-if #'(lambda(x)
+ (string= (d:uri x) "http://simpsons/homer_simpson"))
+ (d:psis homer)))
+ (is (= (length (d:locators homer)) 1))
+ (is-true (find-if #'(lambda(x)
+ (string= (d:uri x) "http://some.where/resource"))
+ (d:locators homer)))
+ (is (= (length (d:item-identifiers homer)) 1))
+ (is-true (find-if #'(lambda(x)
+ (string= (d:uri x) "http://simpsons/ii/homer"))
+ (d:item-identifiers homer)))
+ (is (= (length (d:names homer)) 2))
+ (let ((homer-fn (find-if #'(lambda(x)
+ (eql (instance-of x) firstName))
+ (d:names homer)))
+ (homer-ln (find-if #'(lambda(x)
+ (eql (instance-of x) lastName))
+ (d:names homer)))
+ (homer-occ (find-if #'(lambda(x)
+ (eql (instance-of x) profession))
+ (d:occurrences homer))))
+ (is-true homer-fn)
+ (is-true homer-ln)
+ (is (string= (d:charvalue homer-fn) "Homer J."))
+ (is (string= (d:charvalue homer-ln) "Simpson"))
+ (is (= (length (d:variants homer-fn)) 1))
+ (is (= (length (d:themes (first (d:variants homer-fn)))) 1))
+ (is (eql (first (d:themes (first (d:variants homer-fn)))) display))
+ (is (string= (d:charvalue (first (d:variants homer-fn))) "Homer"))
+ (is (string= (d:datatype (first (d:variants homer-fn))) *xml-string*))
+ (is-true homer-occ)
+ (is (string= (d:charvalue homer-occ) "Safety Inspector"))
+ (is (string= (d:datatype homer-occ) *xml-string*))
+ (is (= (length (d:themes homer-occ)) 1))
+ (is (eql (first (d:themes homer-occ)) en))))))
+
+
+(test test-full-mapping-association
+ "Tests the entire importer module."
+ (let ((dir "data_base")
+ (rdf-file unittests-constants:*full_mapping.rdf*)
+ (tm-id "http://full-mapping/")
+ (document-id "http://full_mapping.rdf"))
+ (when elephant:*store-controller*
+ (elephant:close-store))
+ (fixtures::clean-out-db dir)
+ (rdf-importer:rdf-importer rdf-file dir
+ :tm-id tm-id
+ :document-id document-id)
+ (elephant:open-store (xml-importer:get-store-spec dir))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15))
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1))
+ (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4))
+ (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2))
+ (setf d:*current-xtm* document-id)
+ (let ((married (get-item-by-id "http://simpsons/married"))
+ (husband (get-item-by-id "http://simpsons/husband"))
+ (wife (get-item-by-id "http://simpsons/wife"))
+ (marge (get-item-by-id "http://simpsons/marge"))
+ (homer (get-item-by-id "http://simpsons/homer"))
+ (assoc (first (elephant:get-instances-by-class 'd:AssociationC)))
+ (role-husband
+ (find-if #'(lambda(x)
+ (let ((iis (d:item-identifiers x)))
+ (when (= (length iis) 1)
+ (string= (d:uri (first iis))
+ "http://simpsons/role-husband/ii"))))
+ (elephant:get-instances-by-class 'd:RoleC)))
+ (role-wife
+ (find-if #'(lambda(x)
+ (let ((iis (d:item-identifiers x)))
+ (when (= (length iis) 1)
+ (string= (d:uri (first iis))
+ "http://simpsons/role-wife/ii"))))
+ (elephant:get-instances-by-class 'd:RoleC))))
+ (is-true married)
+ (is-true (empty-p married))
+ (is-true husband)
+ (is-true (empty-p husband))
+ (is-true wife)
+ (is-true (empty-p wife))
+ (is-true role-husband)
+ (is-true role-wife)
+ (is-true marge)
+ (is-true homer)
+ (is (= (length (intersection (list role-husband role-wife)
+ (d:roles assoc)))
+ 2))
+ (is (eql (d:instance-of assoc) married))
+ (is (= (length (d:item-identifiers assoc)) 2))
+ (is (= (length
+ (intersection
+ (list
+ (elephant:get-instance-by-value
+ 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-1")
+ (elephant:get-instance-by-value
+ 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-2"))
+ (d:item-identifiers assoc)))
+ 2))
+ (is (eql (d:instance-of role-husband) husband))
+ (is (eql (d:instance-of role-wife) wife))
+ (is (eql (d:player role-husband) homer))
+ (is (eql (d:player role-wife) marge))
+ (is (= (length (d:item-identifiers role-husband)) 1))
+ (is (= (length (d:item-identifiers role-wife)) 1))
+ (is (string= (d:uri (first (d:item-identifiers role-husband)))
+ "http://simpsons/role-husband/ii"))
+ (is (string= (d:uri (first (d:item-identifiers role-wife)))
+ "http://simpsons/role-wife/ii")))))
+
+
(defun run-rdf-importer-tests()
"Runs all defined tests."
(when elephant:*store-controller*
@@ -3082,4 +3393,7 @@
(it.bese.fiveam:run! 'test-poems-rdf-topics)
(it.bese.fiveam:run! 'test-empty-collection)
(it.bese.fiveam:run! 'test-collection)
- (it.bese.fiveam:run! 'test-xml-base))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-xml-base)
+ (it.bese.fiveam:run! 'test-full-mapping-marge)
+ (it.bese.fiveam:run! 'test-full-mapping-homer)
+ (it.bese.fiveam:run! 'test-full-mapping-association))
\ No newline at end of file
Modified: trunk/src/unit_tests/unittests-constants.lisp
==============================================================================
--- trunk/src/unit_tests/unittests-constants.lisp (original)
+++ trunk/src/unit_tests/unittests-constants.lisp Tue Sep 8 06:54:19 2009
@@ -30,7 +30,8 @@
:*atom_test.xtm*
:*atom-conf.lisp*
:*poems_light.rdf*
- :*poems_light.xtm*))
+ :*poems_light.xtm*
+ :*full_mapping.rdf*))
(in-package :unittests-constants)
@@ -99,3 +100,7 @@
(defparameter *poems_light.xtm*
(asdf:component-pathname
(asdf:find-component *unit-tests-component* "poems_light.xtm")))
+
+(defparameter *full_mapping.rdf*
+ (asdf:component-pathname
+ (asdf:find-component *unit-tests-component* "full_mapping.rdf")))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Tue Sep 8 04:51:36 2009
New Revision: 136
Log:
rdf-exporter: fixed a bug with missing name-types; rdf-importer: fixed a bug with merging/versioning of blank_nodes --> they get an item-identifier concatenated of a predefined prefix and their nodeID or a UUID
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/full_mapping.rdf
trunk/src/xml/rdf/exporter.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/map_to_tm.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp (original)
+++ trunk/src/constants.lisp Tue Sep 8 04:51:36 2009
@@ -61,7 +61,8 @@
:*tm2rdf-occurrencetype-property*
:*tm2rdf-roletype-property*
:*tm2rdf-associationtype-property*
- :*tm2rdf-player-property*))
+ :*tm2rdf-player-property*
+ :*rdf2tm-blank-node-prefix*))
(in-package :constants)
@@ -123,6 +124,8 @@
(defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/"))
+(defparameter *rdf2tm-blank-node-prefix* (concatenate 'string *rdf2tm-ns* "blank_node/"))
+
(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic"))
Modified: trunk/src/unit_tests/full_mapping.rdf
==============================================================================
--- trunk/src/unit_tests/full_mapping.rdf (original)
+++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 04:51:36 2009
@@ -64,7 +64,7 @@
</isi:variant>
</rdf:Description>
</isi:name>
- <!-- <isi:name rdf:resource="id_2345"/> --> <!-- should be merged with id_266 -->
+ <isi:name rdf:resource="id_2345"/> <!-- should be merged with id_266 -->
<isi:name>
<rdf:Description rdf:nodeID="id_277">
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/>
@@ -102,7 +102,7 @@
<isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity>
<isi:role>
<rdf:Description rdf:nodeID="id_292">
- <isi:itemIdentity rdf:datatype="">http://simpsons/role-husband/ii</isi:itemIdentity>
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-husband/ii</isi:itemIdentity>
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
<isi:roletype rdf:resource="http://simpsons/husband"/>
<isi:player rdf:resource="http://simpsons/homer"/>
@@ -117,15 +117,29 @@
</isi:role>
</rdf:Description>
+ <rdf:Description rdf:nodeID="id_295">
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity>
+ </rdf:Description>
+
<rdf:Description>
- <isi:itemIdentity rdf:datatype="">http://simpsons/maried/ii-2</isi:itemIdentity>
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/>
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity>
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-2</isi:itemIdentity>
+ <isi:associationtype rdf:resource="http://simpsons/married"/>
<isi:role>
- <rdf:Description rdf:nodeID="id_295">
- <isi:itemIdentity rdf:datatype="">http://simpsons/role-wife/ii</isi:itemIdentity>
+ <rdf:Description>
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity>
<rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
<isi:roletype rdf:resource="http://simpsons/wife"/>
<isi:player rdf:resource="http://simpsons/marge"/>
</rdf:Description>
</isi:role>
+ <isi:role>
+ <rdf:Description>
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
+ <isi:roletype rdf:resource="http://simpsons/husband"/>
+ <isi:player rdf:resource="http://simpsons/homer"/>
+ </rdf:Description>
+ </isi:role>
</rdf:Description>
-</rdf:RDF>
\ No newline at end of file
+</rdf:RDF>
Modified: trunk/src/xml/rdf/exporter.lisp
==============================================================================
--- trunk/src/xml/rdf/exporter.lisp (original)
+++ trunk/src/xml/rdf/exporter.lisp Tue Sep 8 04:51:36 2009
@@ -39,7 +39,7 @@
to be exported, the same mechanism as
in xtm-exporter")
-(defvar *ns-map* nil) ;; ((:prefix <string> :uri <string>))
+(defvar *ns-map* nil "((:prefix <string> :uri <string>))")
(defun rdf-li-or-uri (uri)
@@ -297,8 +297,9 @@
(cxml:attribute "rdf:nodeID" (make-object-id construct))
(make-isi-type *tm2rdf-name-type-uri*)
(map 'list #'to-rdf-elem (item-identifiers construct))
- (cxml:with-element "isi:nametype"
- (make-topic-reference (instance-of construct)))
+ (when (slot-boundp construct 'instance-of)
+ (cxml:with-element "isi:nametype"
+ (make-topic-reference (instance-of construct))))
(scopes-to-rdf-elems construct)
(cxml:with-element "isi:value"
(cxml:attribute "rdf:datatype" *xml-string*)
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Tue Sep 8 04:51:36 2009
@@ -411,28 +411,25 @@
If about or ID is set there will also be created a new PSI."
(declare (TopicMapC tm))
(let ((topic-id (or about ID nodeID UUID))
- (psi-uri (or about ID)))
+ (psi-uri (or about ID))
+ (ii-uri (unless (or about ID)
+ (concatenate 'string *rdf2tm-blank-node-prefix*
+ (or nodeID UUID)))))
(let ((top
;seems like there is a bug in d:get-item-by-id:
;this functions returns an emtpy topic although there is no one
- ;with a corresponding topic id and/or version and/or xtm-id
+ ;with a corresponding topic id and/or version.
+ ;Thus the version is temporary checked manually.
(let ((inner-top
(get-item-by-id topic-id :xtm-id document-id
:revision start-revision)))
- ;;(when inner-top
- ;; (let ((versions (d::versions inner-top)))
- ;; (unless (find-if #'(lambda(version)
- ;; (= start-revision
- ;; (d::start-revision version)))
- ;; versions)
- ;; (d::add-to-version-history inner-top
- ;; :start-revision start-revision)
- ;; (add-to-topicmap tm inner-top)))))))
- (when (and inner-top
- (find-if #'(lambda(x)
- (= (d::start-revision x) start-revision))
- (d::versions inner-top)))
- inner-top))))
+ (when inner-top
+ (let ((versions (d::versions inner-top)))
+ (when (find-if #'(lambda(version)
+ (= start-revision
+ (d::start-revision version)))
+ versions)
+ inner-top))))))
(if top
top
(elephant:ensure-transaction (:txn-nosync t)
@@ -440,7 +437,12 @@
(list
(make-instance 'PersistentIdC
:uri psi-uri
- :start-revision start-revision)))))
+ :start-revision start-revision))))
+ (iis (when ii-uri
+ (list
+ (make-instance 'ItemIdentifierC
+ :uri ii-uri
+ :start-revision start-revision)))))
(handler-case (let ((top
(add-to-topicmap
tm
@@ -448,6 +450,7 @@
'TopicC
:topicid topic-id
:psis psis
+ :item-identifiers iis
:xtm-id document-id
:start-revision start-revision))))
(format t "t")
@@ -463,12 +466,12 @@
(when lang
(let ((psi-and-topic-id
(concatenate-uri *rdf2tm-scope-prefix* lang)))
- (let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id
- :revision start-revision)))
- (if top
- top
- (make-topic-stub psi-and-topic-id nil nil nil start-revision
- tm :document-id document-id))))))
+ ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id
+; :revision start-revision)))
+; (if top
+; top
+ (make-topic-stub psi-and-topic-id nil nil nil start-revision
+ tm :document-id document-id))))
(defun make-association (top association tm start-revision
Modified: trunk/src/xml/rdf/map_to_tm.lisp
==============================================================================
--- trunk/src/xml/rdf/map_to_tm.lisp (original)
+++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 04:51:36 2009
@@ -71,13 +71,15 @@
(type-instance (get-item-by-psi *type-instance-psi*))
(type (get-item-by-psi *type-psi*)))
(declare (TopicC instance-topic type-topic))
- (let ((assocs (map 'list
- #'(lambda(role)
- (when (and (eql (instance-of role) instance)
- (eql (instance-of (parent role))
- type-instance))
- (parent role)))
- (player-in-roles instance-topic))))
+ (let ((assocs (remove-if
+ #'null
+ (map 'list
+ #'(lambda(role)
+ (when (and (eql (instance-of role) instance)
+ (eql (instance-of (parent role))
+ type-instance))
+ (parent role)))
+ (player-in-roles instance-topic)))))
(map 'list #'(lambda(assoc)
(when (find-if #'(lambda(role)
(and (eql (instance-of role) type)
@@ -86,6 +88,13 @@
(d::delete-construct assoc)))
assocs)
nil))))
+
+
+(defun delete-related-associations (top)
+ "Deletes all associaitons related to the passed topic."
+ (dolist (assoc-role (player-in-roles top))
+ (d::delete-construct (parent assoc-role)))
+ top)
(defun get-isi-roles(assoc-top start-revision)
@@ -109,8 +118,6 @@
(declare (TopicC role-top))
(declare (integer start-revision))
(let ((err-pref "From map-isi-role(): ")
- (role-type-topic (get-item-by-psi *tm2rdf-role-type-uri*
- :revision start-revision))
(ids (map-isi-identifiers role-top start-revision))
(type-assocs
(get-associations-by-type
@@ -133,7 +140,7 @@
(when (= 0 (length role-players))
(error "~aexpect one player but found: ~a"
err-pref (length role-players)))
- (delete-instance-of-association role-top role-type-topic)
+ (delete-related-associations role-top)
(d::delete-construct role-top)
(list :instance-of (first types)
:player (first role-players)
@@ -175,6 +182,7 @@
(when (= 0 (length assoc-roles))
(error "~aexpect at least one role but found: ~a"
err-pref (length assoc-roles)))
+ (delete-related-associations assoc-top)
(d::delete-construct assoc-top)
(with-tm (start-revision document-id tm-id)
(add-to-topicmap
@@ -234,8 +242,6 @@
(declare (NameC name))
(declare (integer start-revision))
(let ((ids (map-isi-identifiers variant-top start-revision))
- (variant-type-topic (get-item-by-psi *tm2rdf-variant-type-uri*
- :revision start-revision))
(scope-assocs
(get-associations-by-type
variant-top start-revision *tm2rdf-scope-property*
@@ -256,7 +262,7 @@
:datatype *xml-string*)))))
(elephant:ensure-transaction (:txn-nosync t)
(map 'list #'d::delete-construct scope-assocs)
- (delete-instance-of-association variant-top variant-type-topic)
+ (delete-related-associations variant-top)
(d::delete-construct variant-top)
(make-construct 'VariantC
:start-revision start-revision
@@ -272,8 +278,6 @@
(declare (TopicC top name-top))
(declare (integer start-revision))
(let ((err-pref "From map-isi-name(): ")
- (name-type-topic (get-item-by-psi *tm2rdf-name-type-uri*
- :revision start-revision))
(ids (map-isi-identifiers name-top start-revision))
(type-assocs
(get-associations-by-type
@@ -314,7 +318,7 @@
(map 'list #'(lambda(variant-top)
(map-isi-variant name variant-top start-revision))
variant-topics)
- (delete-instance-of-association name-top name-type-topic)
+ (delete-related-associations name-top)
(d::delete-construct name-top)
name)))))
@@ -339,8 +343,6 @@
(declare (integer start-revision))
(let ((err-pref "From map-isi-occurrence(): ")
(ids (map-isi-identifiers occ-top start-revision))
- (occurrence-type-topic (get-item-by-psi *tm2rdf-occurrence-type-uri*
- :revision start-revision))
(type-assocs
(get-associations-by-type
occ-top start-revision *tm2rdf-occurrencetype-property*
@@ -371,7 +373,7 @@
(when (/= 1 (length types))
(error "~aexpect one type topic but found: ~a"
err-pref (length types)))
- (delete-instance-of-association occ-top occurrence-type-topic)
+ (delete-related-associations occ-top)
(d::delete-construct occ-top)
(make-construct 'OccurrenceC
:start-revision start-revision
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Tue Sep 8 04:51:36 2009
@@ -53,7 +53,8 @@
*tm2rdf-occurrencetype-property*
*tm2rdf-roletype-property*
*tm2rdf-player-property*
- *tm2rdf-associationtype-property*)
+ *tm2rdf-associationtype-property*
+ *rdf2tm-blank-node-prefix*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
@@ -509,4 +510,4 @@
(list :topicid (get-type-of-node-name elem)
:psi (get-type-of-node-name elem)
:ID nil)))
- (get-types-of-node-content elem tm-id xml-base)))))
+ (get-types-of-node-content elem tm-id xml-base)))))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Mon Sep 7 10:43:54 2009
New Revision: 135
Log:
rdf-importer: added an RDF test file with exported and mapped TM constructs.
Added:
trunk/src/unit_tests/full_mapping.rdf
Modified:
trunk/src/isidorus.asd
trunk/src/xml/rdf/map_to_tm.lisp
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Mon Sep 7 10:43:54 2009
@@ -110,6 +110,7 @@
(:static-file "poems.rdf")
(:static-file "poems_light.rdf")
(:static-file "poems_light.xtm")
+ (:static-file "full_mapping.rdf")
(:file "atom-conf")
(:file "unittests-constants"
:depends-on ("dangling_topicref.xtm"
Added: trunk/src/unit_tests/full_mapping.rdf
==============================================================================
--- (empty file)
+++ trunk/src/unit_tests/full_mapping.rdf Mon Sep 7 10:43:54 2009
@@ -0,0 +1,131 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<rdf:RDF xmlns:isi="http://isidorus/tm2rdf_mapping/"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#"
+ xmlns:xml="http://www.w3.org/XML/1998/namespace">
+ <!-- === topic: marge ==================================================== -->
+ <rdf:Description rdf:about="http://simpsons/marge">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Topic"/>
+ <isi:name>
+ <rdf:Description rdf:nodeID="id_283">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/>
+ <isi:nametype rdf:resource="http://simpsons/firstName"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Marjorie</isi:value>
+ </rdf:Description>
+ </isi:name>
+ <isi:name>
+ <rdf:Description rdf:nodeID="id_285">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/>
+ <isi:nametype rdf:resource="http://simpsons/lastName"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Simpson</isi:value>
+ </rdf:Description>
+ </isi:name>
+ <ns5:profession xmlns:ns5="http://simpsons/" rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Housewife</ns5:profession>
+ <isi:occurrence rdf:nodeID="id_1234"/> <!-- equal to ns5:profession, should be merged -->
+ </rdf:Description>
+
+ <rdf:Description rdf:nodeID="id_1234">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Occurrence"/>
+ <isi:occurrencetype rdf:resource="http://simpsons/profession"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Housewife</isi:value>
+ </rdf:Description>
+
+
+ <rdf:Description rdf:nodeID="id_285">
+ <isi:variant rdf:parseType="Resource">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/>
+ <isi:scope rdf:resource="http://simpsons/display"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Marge</isi:value>
+ </isi:variant>
+ </rdf:Description>
+
+
+ <rdf:Description rdf:about="http://simpsons/marge">
+ <isi:subjectIdentifier rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/marjorie</isi:subjectIdentifier>
+ </rdf:Description>
+
+ <!-- === topic: homer ==================================================== -->
+ <rdf:Description rdf:about="http://simpsons/homer">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Topic"/>
+ <isi:subjectIdentifier rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/homer_simpson</isi:subjectIdentifier>
+ <isi:subjectLocator rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://some.where/resource</isi:subjectLocator>
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/ii/homer</isi:itemIdentity>
+ <isi:name>
+ <rdf:Description rdf:nodeID="id_266">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/>
+ <isi:nametype rdf:resource="http://simpsons/firstName"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer J.</isi:value>
+ <isi:variant>
+ <rdf:Description rdf:nodeID="id_272">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/>
+ <isi:scope rdf:resource="http://simpsons/display"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer</isi:value>
+ </rdf:Description>
+ </isi:variant>
+ </rdf:Description>
+ </isi:name>
+ <!-- <isi:name rdf:resource="id_2345"/> --> <!-- should be merged with id_266 -->
+ <isi:name>
+ <rdf:Description rdf:nodeID="id_277">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/>
+ <isi:nametype rdf:resource="http://simpsons/lastName"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Simpson</isi:value>
+ </rdf:Description>
+ </isi:name>
+ <isi:occurrence>
+ <rdf:Description rdf:nodeID="id_279">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Occurrence"/>
+ <isi:occurrencetype rdf:resource="http://simpsons/profession"/>
+ <isi:scope rdf:resource="http://simpsons/en"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Safety Inspector</isi:value>
+ </rdf:Description>
+ </isi:occurrence>
+ </rdf:Description>
+
+ <rdf:Description rdf:about="id_2345">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/>
+ <isi:nametype rdf:resource="http://simpsons/firstName"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer J.</isi:value>
+ <isi:variant>
+ <rdf:Description rdf:nodeID="id_272">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/>
+ <isi:scope rdf:resource="http://simpsons/display"/>
+ <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer</isi:value>
+ </rdf:Description>
+ </isi:variant>
+ </rdf:Description>
+
+ <!-- === association: married ============================================ -->
+ <rdf:Description rdf:nodeID="id_291">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/>
+ <isi:associationtype rdf:resource="http://simpsons/married"/>
+ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity>
+ <isi:role>
+ <rdf:Description rdf:nodeID="id_292">
+ <isi:itemIdentity rdf:datatype="">http://simpsons/role-husband/ii</isi:itemIdentity>
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
+ <isi:roletype rdf:resource="http://simpsons/husband"/>
+ <isi:player rdf:resource="http://simpsons/homer"/>
+ </rdf:Description>
+ </isi:role>
+ <isi:role>
+ <rdf:Description rdf:nodeID="id_295">
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
+ <isi:roletype rdf:resource="http://simpsons/wife"/>
+ <isi:player rdf:resource="http://simpsons/marge"/>
+ </rdf:Description>
+ </isi:role>
+ </rdf:Description>
+
+ <rdf:Description>
+ <isi:itemIdentity rdf:datatype="">http://simpsons/maried/ii-2</isi:itemIdentity>
+ <isi:role>
+ <rdf:Description rdf:nodeID="id_295">
+ <isi:itemIdentity rdf:datatype="">http://simpsons/role-wife/ii</isi:itemIdentity>
+ <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/>
+ <isi:roletype rdf:resource="http://simpsons/wife"/>
+ <isi:player rdf:resource="http://simpsons/marge"/>
+ </rdf:Description>
+ </isi:role>
+ </rdf:Description>
+</rdf:RDF>
\ No newline at end of file
Modified: trunk/src/xml/rdf/map_to_tm.lisp
==============================================================================
--- trunk/src/xml/rdf/map_to_tm.lisp (original)
+++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 10:43:54 2009
@@ -302,8 +302,8 @@
(map 'list #'d::delete-construct type-assocs)
(map 'list #'d::delete-construct scope-assocs)
(when (/= 1 (length types))
- (error "~aexpect one type topic but found: ~a"
- err-pref (length types)))
+ (error "~aexpect one type topic but found: ~a (~a)"
+ err-pref (length types) value))
(let ((name (make-construct 'NameC
:start-revision start-revision
:topic top
1
0