Author: lgiessmann Date: Sat Sep 5 11:53:27 2009 New Revision: 132

Log: rdf-importer: rollback to revision 127 of the rdf-importer, added a new file for mapping already imported topics to occurrences, names, associaitons, etc.; fixed also some problems in the importer; currently a bug seems to exist in the rdf-importer, therefor versioning is not working corretcly

Added: trunk/src/xml/rdf/map_to_tm.lisp Removed: trunk/src/xml/rdf/isidorus_constructs_tools.lisp Modified: trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/unit_tests/poems.xtm trunk/src/unit_tests/rdf_exporter_test.lisp trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp

Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Sat Sep 5 11:53:27 2009 @@ -125,25 +125,25 @@

(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")

-(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "Topic")) +(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic"))

-(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "Name")) +(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "types/Name"))

(defparameter *tm2rdf-name-property* (concatenate 'string *tm2rdf-ns* "name"))

-(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "Variant")) +(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "types/Variant"))

(defparameter *tm2rdf-variant-property* (concatenate 'string *tm2rdf-ns* "variant"))

-(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "Occurrence")) +(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "types/Occurrence"))

(defparameter *tm2rdf-occurrence-property* (concatenate 'string *tm2rdf-ns* "occurrence"))

-(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "Role")) +(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "types/Role"))

(defparameter *tm2rdf-role-property* (concatenate 'string *tm2rdf-ns* "role"))

-(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "Association")) +(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "types/Association"))

(defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association"))

Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sat Sep 5 11:53:27 2009 @@ -53,10 +53,10 @@ "exporter_xtm2.0")))) (:module "rdf" :components ((:file "rdf_tools") - (:file "isidorus_constructs_tools" + (:file "map_to_tm" :depends-on ("rdf_tools")) (:file "importer" - :depends-on ("rdf_tools" "isidorus_constructs_tools")) + :depends-on ("rdf_tools" "map_to_tm")) (:file "exporter")) :depends-on ("xtm"))) :depends-on ("constants"

Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sat Sep 5 11:53:27 2009 @@ -329,8 +329,8 @@ (lambda(version) (and (>= revision (start-revision version)) (or - (< revision (end-revision version)) - (= 0 (end-revision version))))) + (< revision (end-revision version)) + (= 0 (end-revision version))))) (versions constr)) constr))))

Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Sat Sep 5 11:53:27 2009 @@ -2605,7 +2605,7 @@ </tm:topic>

tm:association - <tm:itemIdentity href="wirtten-by-zauberlehrling-goethe"/> + <tm:itemIdentity href="written-by-zauberlehrling-goethe"/> tm:type<tm:topicRef href="#written-by"/></tm:type> tm:role tm:type<tm:topicRef href="#writer"/></tm:type> @@ -2618,7 +2618,7 @@ </tm:association>

tm:association - <tm:itemIdentity href="wirtten-by-erlkoenig-goethe"/> + <tm:itemIdentity href="wrrtten-by-erlkoenig-goethe"/> tm:type<tm:topicRef href="#written-by"/></tm:type> tm:role tm:type<tm:topicRef href="#writer"/></tm:type>

Modified: trunk/src/unit_tests/rdf_exporter_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_exporter_test.lisp (original) +++ trunk/src/unit_tests/rdf_exporter_test.lisp Sat Sep 5 11:53:27 2009 @@ -86,23 +86,30 @@ "Returns t if the owner-element has a node that corresponds to a role with the given parameters." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (length (dom:child-nodes item)) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (= (length (dom:child-nodes descr)) (+ 3 (length item-identifiers))) (string= node-ns *tm2rdf-ns*) (string= node-name "role") - (type-p item (concatenate 'string *tm2rdf-ns* "Role")) + (type-p descr (concatenate 'string *tm2rdf-ns* "types/Role")) (if player-uri - (property-p item *tm2rdf-ns* "player" + (property-p descr *tm2rdf-ns* "player" :resource player-uri) - (property-p item *tm2rdf-ns* "player" + (property-p descr *tm2rdf-ns* "player" :nodeID player-id)) - (property-p item *tm2rdf-ns* "roletype" + (property-p descr *tm2rdf-ns* "roletype" :resource roletype-uri) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))))) return t))

@@ -193,26 +200,35 @@ "Returns t if the owner contains a variant element with the passed characteristics." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (+ (length variant-scopes) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (rdf-importer::get-ns-attribute descr "nodeID") + (= (+ (length variant-scopes) (length item-identifiers) 2) (length (dom:child-nodes owner-elem))) (string= node-ns *tm2rdf-ns*) (string= node-name "variant") - (literal-p item *tm2rdf-ns* "value" variant-value + (literal-p descr *tm2rdf-ns* "value" variant-value :datatype datatype) (= (length variant-scopes) (length (loop for scope in variant-scopes - when (property-p item *tm2rdf-ns* "scope" + when (property-p descr *tm2rdf-ns* "scope" :resource scope) collect scope))) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))) - (type-p item (concatenate 'string *tm2rdf-ns* "Variant")))) + (type-p descr (concatenate 'string *tm2rdf-ns* + "types/Variant")))) return t))

@@ -220,35 +236,43 @@ &key (variants nil)) "Returns t if the parent node owns a name with the given characterics." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (length (dom:child-nodes item)) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (rdf-importer::get-ns-attribute descr "nodeID") + (= (length (dom:child-nodes descr)) (+ 3 (length name-scopes) (length item-identifiers) (length variants))) (string= node-ns *tm2rdf-ns*) (string= node-name "name") - (type-p item (concatenate 'string *tm2rdf-ns* - "Name")) - (property-p item *tm2rdf-ns* "nametype" :resource name-type) + (type-p descr (concatenate 'string *tm2rdf-ns* + "types/Name")) + (property-p descr *tm2rdf-ns* "nametype" :resource name-type) (= (length name-scopes) (length (loop for scope in name-scopes - when (property-p item *tm2rdf-ns* "scope" + when (property-p descr *tm2rdf-ns* "scope" :resource scope) collect scope))) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))) (= (length variants) (length (loop for variant in variants when (variant-p - item (getf variant :scopes) + descr (getf variant :scopes) (getf variant :item-identifiers) (getf variant :value) :datatype (getf variant :datatype)) collect variant))) - (literal-p item *tm2rdf-ns* "value" name-value))) + (literal-p descr *tm2rdf-ns* "value" name-value))) return t))

@@ -257,27 +281,34 @@ &key (datatype *xml-string*)) "Returns t if the parent node owns an occurrence with the given characterics." (loop for item across (dom:child-nodes owner-elem) - when (let ((node-ns (dom:namespace-uri item)) - (node-name (rdf-importer::get-node-name item))) - (and (= (length (dom:child-nodes item)) + when (let* ((node-ns (dom:namespace-uri item)) + (node-name (rdf-importer::get-node-name item)) + (content (rdf-importer::child-nodes-or-text item :trim t)) + (descr (when (and (not (stringp content)) + (= (length content) 1)) + (elt content 0)))) + (and descr + (string= (dom:namespace-uri descr) *rdf-ns*) + (string= (rdf-importer::get-node-name descr) "Description") + (= (length (dom:child-nodes descr)) (+ 3 (length occurrence-scopes) (length item-identifiers))) (string= node-ns *tm2rdf-ns*) (string= node-name "occurrence") - (type-p item (concatenate 'string *tm2rdf-ns* - "Occurrence")) - (property-p item *tm2rdf-ns* "occurrencetype" + (type-p descr (concatenate 'string *tm2rdf-ns* + "types/Occurrence")) + (property-p descr *tm2rdf-ns* "occurrencetype" :resource occurrence-type) (= (length occurrence-scopes) (length (loop for scope in occurrence-scopes - when (property-p item *tm2rdf-ns* "scope" + when (property-p descr *tm2rdf-ns* "scope" :resource scope) collect scope))) (= (length item-identifiers) (length (loop for ii in item-identifiers - when (identifier-p item ii) + when (identifier-p descr ii) collect ii))) - (literal-p item *tm2rdf-ns* "value" occurrence-value + (literal-p descr *tm2rdf-ns* "value" occurrence-value :datatype datatype))) return t))

@@ -308,7 +339,7 @@ (= (length (dom:child-nodes x)) 7)) goethes))) (is-true me) - (is (type-p me "http://isidorus/tm2rdf_mapping/Topic")) + (is (type-p me "http://isidorus/tm2rdf_mapping/types/Topic")) (is (type-p me "http://some.where/types/Author")) (is (literal-p me *sw-arc* "lastName" "von Goethe")) @@ -352,7 +383,7 @@ erlkoenigs))) (is-true me) (is-true (type-p me "http://some.where/types/Ballad")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Topic"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) (is-true (literal-p me *sw-arc* "content" "Wer reitet so spät durch Nacht und Wind? ..." :xml-lang "de")) @@ -410,7 +441,7 @@ zauberlehrlings))) (is-true me) (is-true (type-p me "http://some.where/types/Poem")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Topic"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) (is-true (identifier-p me "http://some.where/poem/Zauberlehrling" :what "subjectIdentifier")) (is-true (identifier-p @@ -694,7 +725,7 @@ (is (= (length (get-resources-by-id schiller-id)) 1)) (let ((me (elt (get-resources-by-id schiller-id) 0))) (is-true (type-p me "http://some.where/types/Author")) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Topic"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Topic"))) (is-true (literal-p me *sw-arc* "authorInfo" "http://de.wikipedia.org/wiki/Schiller" :datatype *xml-uri*)) @@ -828,7 +859,7 @@ (is (= (length assocs))) (let ((me (elt assocs 0))) (is (= (length (dom:child-nodes me)) 7)) - (is-true (type-p me (concatenate 'string *tm2rdf-ns* "Association"))) + (is-true (type-p me (concatenate 'string *tm2rdf-ns* "types/Association"))) (is-true (identifier-p me "http://some.where/test-association")) (is-true (property-p me *tm2rdf-ns* "associationtype" :resource (concatenate

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 Sat Sep 5 11:53:27 2009 @@ -21,7 +21,6 @@ *tm2rdf-ns* *xml-ns* *xml-string* - *xml-uri* *instance-psi* *type-psi* *type-instance-psi* @@ -67,14 +66,7 @@ :test-poems-rdf-topics :test-empty-collection :test-collection - :test-xml-base - :test-get-type-psis - :test-get-all-type-psis - :test-isidorus-type-p - :test-get-all-isidorus-nodes-by-id - :test-import-isidorus-name - :test-import-isidorus-occurrence - :test-import-isidorus-association)) + :test-xml-base))

(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))

@@ -3068,650 +3060,6 @@ "/test") "http://base-3/test")))))))

- -(test test-get-type-psis - "Tests the function get-type-psis." - (let ((tm-id "http://test-tm/") - (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - "xmlns:sw="http://test/arcs/%5C%22%3E" - " <sw:Node rdf:about="http://sw/node%5C"" - " rdf:type="http://sw/Node-1%5C%22%3E" - " <sw:type rdf:resource="anyResource"/>" - " <rdf:type rdf:resource="Node-2"/>" - " <rdf:type rdf:resource="http://sw/Node-3%5C%22/%3E" - " <rdf:type rdf:nodeID="anyType"/>" - " </sw:Node>" - - " <rdf:Description rdf:about="http://sw/emtpy%5C%22/%3E" - "</rdf:RDF>"))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) - (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) - (is (= (length (rdf-importer::child-nodes-or-text rdf-node)) 2)) - (let ((resource-1 - (elt (rdf-importer::child-nodes-or-text rdf-node) 0)) - (resource-2 - (elt (rdf-importer::child-nodes-or-text rdf-node) 1)) - (types (list "http://test/arcs/Node" "http://sw/Node-1" - "http://xml-base/Node-2" "http://sw/Node-3")) - (types-2 (list "http://test/arcs/Node" "http://sw/Node-1" - (concatenate 'string tm-id "Node-2") - "http://sw/Node-3"))) - (is-true resource-1) - (is-true resource-2) - (is (= (length - (intersection - types - (rdf-importer::get-type-psis - resource-1 tm-id - :parent-xml-base "http://xml-base/") - :test #'string=)) - (length types))) - (is (= (length - (intersection - types-2 - (rdf-importer::get-type-psis resource-1 tm-id) - :test #'string=)) - (length types-2))) - (is-false (rdf-importer::get-type-psis - resource-2 tm-id - :parent-xml-base "http://xml-base/"))))))) - - -(test test-get-all-type-psis - "Tests the functions get-all-type-psis, get-type-psis-across-dom and - get-type-psis." - (let ((tm-id "http://test-tm/") - (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - "xmlns:sw="http://test/arcs/%5C%22%3E" - " <rdf:Description rdf:nodeID="anyNode">" - " <rdf:type rdf:resource="http://type-1%5C%22/%3E" - " sw:arc" - " <rdf:Description rdf:nodeID="anyNode" " - " rdf:type="http://type-2%5C%22/%3E" - " </sw:arc>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID="anotherNode">" - " <rdf:type rdf:resource="http://type-3%5C%22/%3E" - " </rdf:Description>" - - " <sw:NodeType rdf:nodeID="anyNode"/>" - - " <rdf:Description rdf:nodeID="anyNode" " - " rdf:datatype="anyDatatype">" - " <rdf:type rdf:resource="http://type-7%5C%22/%3E" - " </rdf:Description>" - - " <rdf:Description rdf:about="http://a-node%5C%22%3E" - " sw:arc" - " <rdf:Description rdf:about="http://b-node%5C%22%3E" - " <rdf:type rdf:resource="http://type-5%5C%22/%3E" - " rdf:arc" - " <rdf:Description rdf:nodeID="anyNode">" - " <rdf:type rdf:resource="http://type-5%5C%22/%3E" - " <rdf:type rdf:resource="http://type-6%5C%22/%3E" - " </rdf:Description>" - " </rdf:arc>" - " </rdf:Description>" - " </sw:arc>" - " </rdf:Description>" - "</rdf:RDF>"))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 5)) - (let ((any-node-1 (elt (rdf-importer::child-nodes-or-text root) 0)) - (another-node (elt (rdf-importer::child-nodes-or-text root) 1)) - (fn-types (list "http://type-1" "http://type-2" - "http://test/arcs/NodeType" "http://type-5" - "http://type-6")) - (any-node-4 (elt (rdf-importer::child-nodes-or-text root) 3))) - (let ((types-1 (rdf-importer::get-all-type-psis any-node-1 tm-id)) - (types-4 (rdf-importer::get-all-type-psis any-node-4 tm-id)) - (types-another-node (rdf-importer::get-all-type-psis - another-node tm-id))) - (is (= (length (intersection fn-types types-1 :test #'string=)) - (length fn-types))) - (is (= (length types-another-node) 1)) - (is (string= "http://type-3" - (first types-another-node))) - (is (= (length (intersection fn-types types-4 :test #'string=)) - (length fn-types)))))))) - - -(test test-isidorus-type-p - "Tests the function isidorus-type-p." - (let ((tm-id "http://test-tm/") - (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - "xmlns:sw="http://test/arcs/%5C" " - "xmlns:isi="" *tm2rdf-ns* "">" - " <isi:Topic rdf:about="http://node-1%5C%22%3E" - " isi:name" - " <rdf:Description rdf:nodeID="name-id"/>" - " </isi:name>" - " <isi:occurrence rdf:nodeID="occurrence-id"/>" - " isi:occurrence" - " rdf:Description" - " <rdf:type rdf:resource="" - *tm2rdf-occurrence-type-uri* ""/>" - " </rdf:Description>" - " </isi:occurrence>" - " </isi:Topic>" - - " <rdf:Description rdf:nodeID="name-id">" - " <rdf:type rdf:resource="" *tm2rdf-name-type-uri*""/>" - " isi:variant" - " <isi:Variant rdf:nodeID="variant-id"/>" - " </isi:variant>" - " </rdf:Description>" - - " <isi:Occurrence rdf:nodeID="occurrence-id"/>" - - " <rdf:Description rdf:nodeID="association-id">" - " <rdf:type rdf:resource="" - *tm2rdf-association-type-uri* ""/>" - " isi:role" - " <isi:Role rdf:nodeID="role-id"/>" - " </isi:role>" - " </rdf:Description>" - "</rdf:RDF>"))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 4)) - (let ((topic-node (elt (rdf-importer::child-nodes-or-text root) 0)) - (association-node (elt (rdf-importer::child-nodes-or-text root) 3))) - (let ((topic-name (elt (rdf-importer::child-nodes-or-text topic-node) - 0)) - (topic-occurrence-1 (elt (rdf-importer::child-nodes-or-text - topic-node) - 1)) - (topic-occurrence-2 (elt (rdf-importer::child-nodes-or-text - topic-node) - 2)) - (association-role (elt (rdf-importer::child-nodes-or-text - association-node) - 1)) - (name-variant (elt (rdf-importer::child-nodes-or-text - (elt (rdf-importer::child-nodes-or-text root) - 1)) - 1))) - (is-true (rdf-importer::isidorus-type-p topic-node tm-id - 'rdf-importer::topic)) - (is-true (rdf-importer::isidorus-type-p association-node tm-id - 'rdf-importer::association)) - (is-true (rdf-importer::isidorus-type-p topic-name tm-id - 'rdf-importer::name)) - (is-true (rdf-importer::isidorus-type-p name-variant tm-id - 'rdf-importer::variant)) - (is-true (rdf-importer::isidorus-type-p topic-occurrence-1 tm-id - 'rdf-importer::occurrence)) - (is-true (rdf-importer::isidorus-type-p topic-occurrence-2 tm-id - 'rdf-importer::occurrence)) - (is-true (rdf-importer::isidorus-type-p association-role tm-id - 'rdf-importer::role)) - (is-false (rdf-importer::isidorus-type-p - (elt (rdf-importer::child-nodes-or-text root) 1) tm-id - 'rdf-importer::name)) - (is-false (rdf-importer::isidorus-type-p - (elt (rdf-importer::child-nodes-or-text root) 2) tm-id - 'rdf-importer::occurrence))))))) - - -(test test-get-all-isidorus-nodes-by-id - "Tests the function get-all-isidorus-nodes-by-id." - (let ((doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - "xmlns:sw="http://test/arcs/%5C%22%3E" - " <rdf:Description rdf:nodeID="node-id-1"/>" - " <rdf:Description rdf:nodeID="node-id-2"/>" - " <rdf:Description rdf:nodeID="node-id-1">" - " <sw:arc rdf:nodeID="node-id-2"/>" - " </rdf:Description>" - " <rdf:Description rdf:nodeID="node-id-3">" - " <sw:arc rdf:nodeID="node-id-1"/>" - " <sw:arc rdf:nodeID="node-id-4"/>" - " </rdf:Description>" - " <sw:Node rdf:nodeID="node-id-4" " - " xml:base="http://base/%5C"" - " xml:lang="de">" - " sw:arc" - " <rdf:Description rdf:nodeID="node-id-1" " - " xml:base="suffix"/>" - " </sw:arc>" - " </sw:Node>" - "</rdf:RDF>"))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0)) - (description (concatenate 'string *rdf-ns* "Description")) - (sw-node "http://test/arcs/Node")) - (let ((node-id-1 (list - (list :elem (elt (rdf-importer::child-nodes-or-text - root) 0) - :xml-base nil) - (list :elem (elt (rdf-importer::child-nodes-or-text - root) 2) - :xml-base nil) - (list :elem (elt - (rdf-importer::child-nodes-or-text - (elt - (rdf-importer::child-nodes-or-text - (elt (rdf-importer::child-nodes-or-text - root) 4)) 0)) 0) - :xml-base "http://base/" - :xml-lang "de"))) - (node-id-2 (elt (rdf-importer::child-nodes-or-text root) 1)) - (node-id-3 (elt (rdf-importer::child-nodes-or-text root) 3)) - (node-id-4 (elt (rdf-importer::child-nodes-or-text root) 4))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 5)) - (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-3" root nil)) 1)) - (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-3" root nil)) :elem) - node-id-3)) - (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-2" root nil)) 1)) - (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-2" root description)) :elem) - node-id-2)) - (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :elem) - node-id-4)) - (is-false (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :xml-base)) - (is-false (getf (first (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-4" root sw-node)) :xml-lang)) - (is (= (length (intersection - node-id-1 - (rdf-importer::get-all-isidorus-nodes-by-id - "node-id-1" root description) - :test #'(lambda(x y) - (and (eql (getf x :elem) (getf y :elem)) - (string= (getf x :xml-base) - (getf y :xml-base)))))) - (length node-id-1))))))) - - -(test test-import-isidorus-name - "Tests all functions that are responsible to import a resource - representing isidorus:Name." - (let ((revision-1 100) - (tm-id "http://test/tm-id") - (document-id "doc-id") - (db-dir "./data_base") - (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - " xmlns:sw="http://test/arcs/%5C"" - " xmlns:isi="" *tm2rdf-ns* "">" - " <rdf:Description rdf:about="http://node-1%5C%22%3E" - " isi:subjectIdentifierhttp://topic-psi-1</isi:subjectIdentifier>" - " isi:subjectLocatorhttp://topic-sl-1</isi:subjectLocator>" - " isi:itemIdentityhttp://topic-ii-1</isi:itemIdentity>" - " <sw:arc rdf:resource="http://resource-1%5C%22/%3E" - " isi:name" - " isi:Name" - " isi:itemIdentityhttp://itemIdentity-1</isi:itemIdentity>" - " isi:itemIdentityhttp://itemIdentity-2</isi:itemIdentity>" - " <isi:scope rdf:resource="http://scope-1%5C%22/%3E" - " <isi:scope rdf:resource="http://scope-2%5C%22/%3E" - " <isi:value rdf:datatype="anyDatatype">value-1</isi:value>" - " <isi:nametype rdf:resource="http://nametype-1%5C%22/%3E" - " <isi:variant rdf:nodeID="variant-1"/>" - " </isi:Name>" - " </isi:name>" - " <isi:name rdf:parseType="Resource">" - " <rdf:type rdf:resource="" *tm2rdf-name-type-uri* ""/>" - " isi:itemIdentityhttp://itemIdentity-4</isi:itemIdentity>" - " <isi:value rdf:datatype="anyDatatype">value-3</isi:value>" - " <isi:nametype rdf:resource="http://nametype-2%5C%22/%3E" - " <isi:variant rdf:parseType="Resource">" - " rdf:type" - " <rdf:Description rdf:about="" *tm2rdf-variant-type-uri* ""/>" - " </rdf:type>" - " isi:valuevalue-4</isi:value>" - " isi:scope" - " <rdf:Description rdf:about="http://scope-3%5C%22/%3E" - " </isi:scope>" - " </isi:variant>" - " </isi:name>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID="variant-1">" - " <isi:scope rdf:resource="http://scope-3%5C%22/%3E" - " <isi:value rdf:datatype="dt-2">value-2</isi:value>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID="variant-1">" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-3</isi:itemIdentity>" - " <rdf:type rdf:resource="" *tm2rdf-variant-type-uri* ""/>" - " <isi:scope rdf:resource="http://scope-4%5C%22/%3E" - " </rdf:Description>" - "</rdf:RDF>"))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 3)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (rdf-importer::import-dom root revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:NameC)) 2)) - (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 27)) - (is-false (find-if #'(lambda(x) - (not (d:psis x))) - (elephant:get-instances-by-class 'd:TopicC))) - (is-true (d:get-item-by-psi "http://node-1")) - (is-true (d:get-item-by-psi "http://topic-psi-1")) - (is-true (d:get-item-by-psi "http://resource-1")) - (is-true (d:get-item-by-psi "http://scope-1")) - (is-true (d:get-item-by-psi "http://scope-2")) - (is-true (d:get-item-by-psi "http://scope-3")) - (is-true (d:get-item-by-psi "http://scope-4")) - (is-true (d:get-item-by-psi "http://nametype-1")) - (is-true (d:get-item-by-psi "http://nametype-1")) - (is-true (d:get-item-by-psi "http://test/arcs/arc")) - (let ((top (d:get-item-by-psi "http://node-1")) - (nt-1 (d:get-item-by-psi "http://nametype-1")) - (nt-2 (d:get-item-by-psi "http://nametype-2")) - (scope-1 (d:get-item-by-psi "http://scope-1")) - (scope-2 (d:get-item-by-psi "http://scope-2")) - (scope-3 (d:get-item-by-psi "http://scope-3")) - (scope-4 (d:get-item-by-psi "http://scope-4"))) - (is (= (length (d:psis top)) 2)) - (is-true (find (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri - "http://topic-psi-1") - (d:psis top))) - (is (= (length (d:item-identifiers top)) 1)) - (is (string= (d:uri (first (d:item-identifiers top))) - "http://topic-ii-1")) - (is (= (length (d:locators top)) 1)) - (is (string= (d:uri (first (d:locators top))) - "http://topic-sl-1")) - (is (= (length (d:names top)) 2)) - (let ((name-1 (find-if #'(lambda(x) - (eql (d:instance-of x) nt-1)) - (d:names top))) - (name-2 (find-if #'(lambda(x) - (eql (d:instance-of x) nt-2)) - (d:names top)))) - (is-true name-1) - (is-true name-2) - (is (= (length (d:item-identifiers name-1)) 2)) - (is (= (length - (intersection - (d:item-identifiers name-1) - (list (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-1") - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-2")))) - 2)) - (is (= (length (d:item-identifiers name-2)) 1)) - (is (string= (d:uri (first (d:item-identifiers name-2))) - "http://itemIdentity-4")) - (is (= (length (d:themes name-1)) 2)) - (is (= (length (intersection (list scope-1 scope-2) - (d:themes name-1))) - 2)) - (is-false (d:themes name-2)) - (is (string= (d:charvalue name-1) "value-1")) - (is (string= (d:charvalue name-2) "value-3")) - (is (= (length (d:variants name-1)) 1)) - (is (= (length (d:variants name-2)) 1)) - (let ((variant-1 (first (d:variants name-1))) - (variant-2 (first (d:variants name-2)))) - (is (= (length (d:item-identifiers variant-1)) 1)) - (is (string= (d:uri (first (d:item-identifiers variant-1))) - "http://itemIdentity-3")) - (is-false (d:item-identifiers variant-2)) - (is (= (length (d:themes variant-1)) 4)) - (is (= (length (intersection (list scope-3 scope-4 - scope-1 scope-2) - (d:themes variant-1))) - 4)) - (is (= (length (d:themes variant-2)) 1)) - (is (eql scope-3 (first (d:themes variant-2)))) - (is (string= (d:charvalue variant-1) - "value-2")) - (is (string= (d:charvalue variant-2) - "value-4")) - (is (string= (d:datatype variant-1) - (concatenate 'string tm-id "/dt-2"))) - (is (string= (d:datatype variant-2) - *xml-string*)))))))) - - -(test test-import-isidorus-occurrence - "Tests all functions that are responsible to import a resource - representing isidorus:Occurrence." - (let ((revision-1 100) - (tm-id "http://test/tm-id") - (document-id "doc-id") - (db-dir "./data_base") - (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - " xmlns:sw="http://test/arcs/%5C"" - " xmlns:isi="" *tm2rdf-ns* "">" - " <rdf:Description rdf:about="http://node-1%5C%22%3E" - " <sw:arc rdf:resource="http://resource-1%5C%22/%3E" - " <isi:occurrence rdf:type="http://isidorus/tm2rdf_mapping/Occurrence%5C%22%3E" - " <isi:occurrencetype rdf:resource="http://occurrence-1%5C%22/%3E" - " <isi:value rdf:datatype="dt-1">value-1</isi:value>" - " </isi:occurrence>" - " <isi:occurrence rdf:nodeID="occurrence-2"/>" - " isi:occurrence" - " <isi:Occurrence rdf:nodeID="occurrence-2">" - " <isi:occurrencetype rdf:resource="http://occurrence-2%5C%22/%3E" - " <isi:scope rdf:resource="http://scope-1%5C%22/%3E" - " </isi:Occurrence>" - " </isi:occurrence>" - " <isi:occurrence rdf:parseType="Resource">" - " <rdf:type rdf:resource="" *tm2rdf-occurrence-type-uri* ""/>" - " <isi:occurrencetype rdf:resource="http://occurrence-3%5C%22/%3E" - " <!-- should get the charvalue '' of type xml-string -->" - " </isi:occurrence>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID="occurrence-2">" - " <isi:scope rdf:resource="http://scope-2%5C%22/%3E" - " isi:valuevalue-2</isi:value>" - " <isi:occurrencetype rdf:resource="http://occurrence-2%5C%22/%3E" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-1</isi:itemIdentity>" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-2</isi:itemIdentity>" - " isi:shouldBeIgnoredanyText</isi:shouldBeIgnored>" - " </rdf:Description>" - "</rdf:RDF>"))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 2)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (rdf-importer::import-dom root revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 3)) - (is (= (length (elephant:get-instances-by-class 'd:NameC))) 0) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 26)) - (let ((node-1 (d:get-item-by-psi "http://node-1")) - (occurrence-1 (d:get-item-by-psi "http://occurrence-1")) - (occurrence-2 (d:get-item-by-psi "http://occurrence-2")) - (occurrence-3 (d:get-item-by-psi "http://occurrence-3")) - (scope-1 (d:get-item-by-psi "http://scope-1")) - (scope-2 (d:get-item-by-psi "http://scope-2"))) - (is-true node-1) - (is-true occurrence-1) - (is-true occurrence-2) - (is-true occurrence-3) - (is-true scope-1) - (is-true scope-2) - (let ((occ-1 (find-if #'(lambda(x) - (eql (d:instance-of x) occurrence-1)) - (d:occurrences node-1))) - (occ-2 (find-if #'(lambda(x) - (eql (d:instance-of x) occurrence-2)) - (d:occurrences node-1))) - (occ-3 (find-if #'(lambda(x) - (eql (d:instance-of x) occurrence-3)) - (d:occurrences node-1)))) - (is-true occ-1) - (is-true occ-2) - (is-true occ-3) - (is-false (d:item-identifiers occ-1)) - (is-false (d:themes occ-1)) - (is (string= (d:charvalue occ-1) "value-1")) - (is (string= (d:datatype occ-1) (concatenate 'string tm-id "/dt-1"))) - (is (= (length (intersection - (d:item-identifiers occ-2) - (list (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri - "http://itemIdentity-1") - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri - "http://itemIdentity-2")))) - 2)) - (is (= (length (intersection (list scope-1 scope-2) - (d:themes occ-2))) - 2)) - (is (string= (d:charvalue occ-2) "value-2")) - (is (string= (d:datatype occ-2) *xml-string*)) - (is-false (d:item-identifiers occ-3)) - (is-false (d:themes occ-3)) - (is (string= (d:charvalue occ-3) "")) - (is (string= (d:datatype occ-3) *xml-string*))))))) - - -(test test-import-isidorus-association - "Tests all functions that are responsible to import a resource - representing isidorus:Association." - (let ((revision-1 100) - (tm-id "http://test/tm-id") - (document-id "doc-id") - (db-dir "./data_base") - (doc-1 - (concatenate 'string "<rdf:RDF xmlns:rdf="" *rdf-ns* "" " - " xmlns:sw="http://test/arcs/%5C"" - " xmlns:isi="" *tm2rdf-ns* "">" - " <rdf:Description rdf:nodeID="association-1">" - " <rdf:type rdf:resource="" *tm2rdf-association-type-uri* ""/>" - " <isi:associationtype rdf:resource="http://associationtype-1%5C%22/%3E" - " isi:scope" - " <rdf:Description rdf:about="http://scope-1%5C%22%3E" - " <rdf:type rdf:resource="" *tm2rdf-topic-type-uri* ""/>" - " <isi:subjectLocator rdf:datatype="" *xml-uri* "">http://sl-1</isi:subjectLocator>" - " <isi:subjectLocator rdf:datatype="" *xml-uri* "">http://sl-2</isi:subjectLocator>" - " <isi:name rdf:parseType="Resource">" - " <rdf:type rdf:resource="" *tm2rdf-name-type-uri* ""/>" - " <isi:nametype rdf:resource="http://nametype-1%5C%22/%3E" - " <isi:value rdf:datatype="" *xml-string* "">value-1</isi:value>" - " <isi:scope rdf:parseType="Resource">" - " <sw:arc rdf:parseType="Literal">value-of-arc</sw:arc>" - " </isi:scope>" - " </isi:name>" - " </rdf:Description>" - " </isi:scope>" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-a1</isi:itemIdentity>" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-a2</isi:itemIdentity>" - " <isi:role rdf:nodeID="role-1"/>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID="role-1">" - " <rdf:type rdf:resource="" *tm2rdf-role-type-uri* ""/>" - " <isi:player rdf:resource="http://player-1%5C%22/%3E" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-3</isi:itemIdentity>" - " <isi:roletype rdf:nodeID="roletype-1"/>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID="association-1">" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-a1</isi:itemIdentity>" - " <isi:scope rdf:resource="http://scope-2%5C%22/%3E" - " <isi:role rdf:parseType="Resource">" - " <rdf:type rdf:resource="" *tm2rdf-role-type-uri* ""/>" - " <isi:player rdf:nodeID="player-2"/>" - " <isi:roletype rdf:resource="http://roletype-2%5C%22/%3E" - " </isi:role>" - " isi:role" - " <rdf:Description rdf:nodeID="role-1">" - " <isi:itemIdentity rdf:datatype="" *xml-uri* "">http://itemIdentity-3</isi:itemIdentity>" - " </rdf:Description>" - " </isi:role>" - " </rdf:Description>" - "</rdf:RDF>"))) - (let ((root (elt (dom:child-nodes (cxml:parse doc-1 - (cxml-dom:make-dom-builder))) - 0))) - (is (= (length (rdf-importer::child-nodes-or-text root)) 3)) - (rdf-init-db :db-dir db-dir :start-revision revision-1) - (rdf-importer::import-dom root revision-1 :tm-id tm-id - :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28)) - (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 1)) - (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) - (setf d::*current-xtm* document-id) - (let ((assoc (first (elephant:get-instances-by-class 'd:AssociationC))) - (assoc-type (d:get-item-by-psi "http://associationtype-1")) - (scope-1 (d:get-item-by-psi "http://scope-1")) - (player-1 (d:get-item-by-psi "http://player-1")) - (player-2 (d:get-item-by-id "player-2")) - (roletype-1 (d:get-item-by-id "roletype-1")) - (roletype-2 (d:get-item-by-psi "http://roletype-2")) - (nametype-1 (d:get-item-by-psi "http://nametype-1")) - (scope-2 (d:get-item-by-psi "http://scope-2"))) - (let ((role-1 (first (d:used-as-type roletype-1))) - (role-2 (first (d:used-as-type roletype-2)))) - (is-true scope-1) - (is (= (length (intersection - (list - (elephant:get-instance-by-value 'd:SubjectLocatorC - 'd:uri "http://sl-1") - (elephant:get-instance-by-value 'd:SubjectLocatorC - 'd:uri "http://sl-2")) - (d:locators scope-1))) - 2)) - (is (= (length (d:names scope-1)) 1)) - (is (eql (d:instance-of (first (d:names scope-1))) nametype-1)) - (is (string= (d:charvalue (first (d:names scope-1))) "value-1")) - (is (= (length (d:themes (first (d:names scope-1)))) 1)) - (is-false (d:psis (first (d:themes (first (d:names scope-1)))))) - (is-true player-1) - (is-true player-2) - (is-true roletype-1) - (is (string= (d:uri (first (d::topic-identifiers roletype-1))) - "roletype-1")) - (is-true roletype-2) - (is-true assoc-type) - (is-true scope-2) - (is-true role-1) - (is (= (length (intersection - (list - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-3")) - (d:item-identifiers role-1))) - 1)) - (is (eql player-1 (d:player role-1))) - (is-true role-2) - (is-false (d:item-identifiers role-2)) - (is (eql player-2 (d:player role-2))) - (is (= (length (intersection (d:roles assoc) - (list role-1 role-2))) - 2)) - (is (= (length (intersection - (d:themes assoc) - (list scope-1 scope-2))) - 2)) - (is (= (length - (intersection - (d:item-identifiers assoc) - (list - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-a1") - (elephant:get-instance-by-value - 'd:ItemIdentifierC 'd:uri "http://itemIdentity-a2")))) - 2))))))) - - (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3734,11 +3082,4 @@ (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) - (it.bese.fiveam:run! 'test-get-type-psis) - (it.bese.fiveam:run! 'test-get-all-type-psis) - (it.bese.fiveam:run! 'test-isidorus-type-p) - (it.bese.fiveam:run! 'test-get-all-isidorus-nodes-by-id) - (it.bese.fiveam:run! 'test-import-isidorus-name) - (it.bese.fiveam:run! 'test-import-isidorus-occurrence) - (it.bese.fiveam:run! 'test-import-isidorus-association)) \ No newline at end of file + (it.bese.fiveam:run! 'test-xml-base)) \ No newline at end of file

Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Sat Sep 5 11:53:27 2009 @@ -20,7 +20,13 @@ *rdf2tm-scope-prefix* *tm2rdf-ns* *type-instance-psi* - *supertype-subtype-psi*) + *supertype-subtype-psi* + *tm2rdf-name-type-uri* + *tm2rdf-variant-type-uri* + *tm2rdf-occurrence-type-uri* + *tm2rdf-topic-type-uri* + *tm2rdf-association-type-uri* + *tm2rdf-role-type-uri*) (:import-from :isidorus-threading with-reader-lock with-writer-lock) @@ -123,11 +129,11 @@ (setf *ns-map* nil))

-(defun make-isi-type (type) +(defun make-isi-type (type-uri) "Creates a rdf:type property with the URL-prefix of *tm2rdf-ns*." - (declare (string type)) + (declare (string type-uri)) (cxml:with-element "rdf:type" - (cxml:attribute "rdf:resource" (concatenate 'string *tm2rdf-ns* type)))) + (cxml:attribute "rdf:resource" type-uri)))

(defun get-ns-prefix (ns-uri) @@ -273,27 +279,31 @@ "Creates a blank node that represents a VariantC element with the properties itemIdentity, scope and value." (cxml:with-element "isi:variant" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Variant") - (map 'list #'to-rdf-elem (item-identifiers construct)) - (scopes-to-rdf-elems construct) - (resourceX-to-rdf-elem construct))) + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + ;(cxml:attribute "rdf:parseType" "Resource") + (make-isi-type *tm2rdf-variant-type-uri*) + (map 'list #'to-rdf-elem (item-identifiers construct)) + (scopes-to-rdf-elems construct) + (resourceX-to-rdf-elem construct))))

(defmethod to-rdf-elem ((construct NameC)) "Creates a blank node that represents a name element with the properties itemIdentity, nametype, value, variant and scope." (cxml:with-element "isi:name" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Name") - (map 'list #'to-rdf-elem (item-identifiers construct)) - (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*) - (cxml:text (charvalue construct))) - (map 'list #'to-rdf-elem (variants construct)))) + ;(cxml:attribute "rdf:parseType" "Resource") + (cxml:with-element "rdf:Description" + (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))) + (scopes-to-rdf-elems construct) + (cxml:with-element "isi:value" + (cxml:attribute "rdf:datatype" *xml-string*) + (cxml:text (charvalue construct))) + (map 'list #'to-rdf-elem (variants construct)))))

(defmethod to-rdf-elem ((construct OccurrenceC)) @@ -308,13 +318,15 @@ (item-identifiers construct) (/= (length (psis (instance-of construct))) 1)) (cxml:with-element "isi:occurrence" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Occurrence") - (map 'list #'to-rdf-elem (item-identifiers construct)) - (cxml:with-element "isi:occurrencetype" - (make-topic-reference (instance-of construct))) - (scopes-to-rdf-elems construct) - (resourceX-to-rdf-elem construct)) + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + ;(cxml:attribute "rdf:parseType" "Resource") + (make-isi-type *tm2rdf-occurrence-type-uri*) + (map 'list #'to-rdf-elem (item-identifiers construct)) + (cxml:with-element "isi:occurrencetype" + (make-topic-reference (instance-of construct))) + (scopes-to-rdf-elems construct) + (resourceX-to-rdf-elem construct))) (with-property construct (cxml:attribute "rdf:datatype" (datatype construct)) (when (themes construct) @@ -349,7 +361,7 @@ (when (or (> (length (psis construct)) 1) ii sl t-names (isi-occurrence-p construct)) - (make-isi-type "Topic")) + (make-isi-type *tm2rdf-topic-type-uri*)) (map 'list #'to-rdf-elem (remove psi (psis construct))) (map 'list #'to-rdf-elem sl) (map 'list #'to-rdf-elem ii) @@ -413,7 +425,7 @@ (association-roles (roles association))) (cxml:with-element "rdf:Description" (cxml:attribute "rdf:nodeID" (make-object-id association)) - (make-isi-type "Association") + (make-isi-type *tm2rdf-association-type-uri*) (cxml:with-element "isi:associationtype" (make-topic-reference association-type)) (map 'list #'to-rdf-elem ii) @@ -428,13 +440,15 @@ (role-type (instance-of construct)) (player-top (player construct))) (cxml:with-element "isi:role" - (cxml:attribute "rdf:parseType" "Resource") - (make-isi-type "Role") - (map 'list #'to-rdf-elem ii) - (cxml:with-element "isi:roletype" - (make-topic-reference role-type)) - (cxml:with-element "isi:player" - (make-topic-reference player-top))))) + (cxml:with-element "rdf:Description" + (cxml:attribute "rdf:nodeID" (make-object-id construct)) + ;(cxml:attribute "rdf:parseType" "Resource") + (make-isi-type *tm2rdf-role-type-uri*) + (map 'list #'to-rdf-elem ii) + (cxml:with-element "isi:roletype" + (make-topic-reference role-type)) + (cxml:with-element "isi:player" + (make-topic-reference player-top))))))

(defun rdf-mapped-association-to-rdf-elem (association)

Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Sat Sep 5 11:53:27 2009 @@ -7,10 +7,6 @@ ;;+----------------------------------------------------------------------------- (in-package :rdf-importer)

- -(defvar *document-id* "isidorus-rdf-document") - - (defun setup-rdf-module (rdf-xml-path repository-path &key tm-id (document-id (get-uuid))) "Sets up the data base by importing core_psis.xtm and @@ -41,13 +37,16 @@ (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - (elephant:ensure-transaction (:txn-nosync t) - (let ((rdf-dom - (dom:document-element (cxml:parse-file - (truename rdf-xml-path) - (cxml-dom:make-dom-builder))))) - (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) - (setf *_n-map* nil)))) + (let ((rdf-dom + (dom:document-element (cxml:parse-file + (truename rdf-xml-path) + (cxml-dom:make-dom-builder))))) + (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) + (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" + (length (elephant:get-instances-by-class 'TopicC)) + (length (elephant:get-instances-by-class 'AssociationC))) + (elephant:close-store) + (setf *_n-map* nil)))

(defun init-rdf-module (&optional (revision (get-revision))) @@ -84,539 +83,49 @@ (let ((children (child-nodes-or-text rdf-dom :trim t))) (when children (loop for child across children - when (non-isidorus-type-p child tm-id :parent-xml-base xml-base) do (import-node child tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang) - when (isidorus-type-p child tm-id 'association - :parent-xml-base xml-base) - do (make-isidorus-association child tm-id start-revision - :parent-xml-base xml-base - :document-id document-id)))) - (if (isidorus-type-p rdf-dom tm-id 'association - :parent-xml-base xml-base) - (make-isidorus-association rdf-dom tm-id start-revision - :parent-xml-base xml-base - :document-id document-id) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) + :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))) (setf *_n-map* nil))

(defun import-node (elem tm-id start-revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) - (format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove (tm-id-p tm-id "import-node") (parse-node 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 ((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) - (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)) - (super-classes - (get-super-classes-of-node-content elem tm-id xml-base)) - (subject-identities (make-isidorus-identifiers - (list elem) - start-revision :what "subjectIdentifier")) - (item-identifiers (make-isidorus-identifiers (list elem) - start-revision)) - (subject-locators (make-isidorus-identifiers - (list elem) start-revision :what "subjectLocator"))) - (with-tm (start-revision document-id tm-id) - (let ((this - (make-topic-stub - about ID nodeID UUID start-revision xml-importer::tm - :document-id document-id - :additional-subject-identifiers subject-identities - :item-identifiers item-identifiers - :subject-locators subject-locators))) - (make-isidorus-names elem this tm-id start-revision - :owner-xml-base fn-xml-base - :document-id document-id) - (make-isidorus-occurrences elem this tm-id start-revision - :owner-xml-base fn-xml-base - :document-id document-id) - (make-literals this literals tm-id start-revision - :document-id document-id) - (make-associations this associations xml-importer::tm - start-revision :document-id document-id) - (make-types this types xml-importer::tm start-revision - :document-id document-id) - (make-super-classes this super-classes xml-importer::tm - 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)))))) - - -(defun make-isidorus-association (elem tm-id start-revision - &key (parent-xml-base nil) - (document-id *document-id*)) - "Creates an association element of the passed DOM node." - (declare (dom:element elem)) - (declare (string tm-id)) - (let ((nodeID (get-ns-attribute elem "nodeID")) - (err-pref "From make-isidorus-association(): ") - (root (elt (dom:child-nodes (dom:owner-document elem)) 0))) - (let ((nodes (if nodeID - (get-all-isidorus-nodes-by-id - nodeId root *tm2rdf-association-type-uri*) - (list (list :elem elem - :xml-base parent-xml-base))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (association-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-associationtype-property* - :document-id document-id)) - (association-scopes (make-scopes nodes tm-id start-revision - :document-id document-id)) - (association-roles (make-isidorus-roles - nodes tm-id start-revision - :document-id document-id))) - (unless association-type - (error "~aassociation type is missing!" err-pref)) - (unless association-roles - (error "~aassociation roles are missing!" err-pref)) - (with-tm (start-revision document-id tm-id) - (add-to-topicmap - xml-importer::tm - (make-construct 'AssociationC - :start-revision start-revision - :item-identifiers item-identities - :instance-of association-type - :themes association-scopes - :roles association-roles))))))) - - -(defun make-isidorus-roles (association-nodes tm-id start-revision - &key (document-id *document-id*)) - "Returns a list of property list of the form - (:instance-of <TopicC> :player <TopicC> :item-identifiers <(ItemIdentifierC)>)." - (declare (string tm-id)) - (let ((err-pref "From make-isidorus-roles(): ") - (all-role-nodes (get-all-role-nodes association-nodes)) - (root (elt (dom:child-nodes (dom:owner-document - (getf (first association-nodes) - :elem))) 0))) - (when (and (not (stringp all-role-nodes)) - (> (length all-role-nodes) 0)) - (loop for property in all-role-nodes - collect - (let ((nodeID (nodeId-of-property-or-child (getf property :elem)))) - (let ((nodes (if nodeID - (get-all-isidorus-nodes-by-id - nodeId root *tm2rdf-role-type-uri*) - (list (list :elem (getf property :elem) - :xml-base (getf property :xml-base) - :xml-lang - (getf property :xml-lang)))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (role-player (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-player-property* - :document-id document-id)) - (role-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-roletype-property* - :document-id document-id))) - (unless role-type - (error "~arole type is missing!" err-pref)) - (unless role-player - (error "~arole player is missing!" err-pref)) - (list :instance-of role-type - :player role-player - :item-identifiers item-identities)))))))) - - -(defun get-all-role-nodes (association-nodes) - "Returns all role nodes of the passed association nodes as a - property list of the form (:elem dom:element :xml-base <string> - :xml-lang <string>." - (let ((nodes - (loop for association in association-nodes - append - (let ((content (child-nodes-or-text (getf association :elem) - :trim t)) - (xml-base (getf association :xml-base)) - (xml-lang (getf association :xml-lang))) - (unless (stringp content) - (loop for property across content - when (let ((node-ns (dom:namespace-uri property)) - (node-name (get-node-name property))) - (string= (concatenate-uri node-ns node-name) - *tm2rdf-role-property*)) - collect (list :elem property - :xml-base (get-xml-base - (getf association :elem) - :old-base xml-base) - :xml-lang - (get-xml-lang (getf association :elem) - :old-lang xml-lang)))))))) - (remove-duplicates - (remove-if #'null nodes) - :test #'(lambda(x y) - (string= (nodeId-of-property-or-child (getf x :elem)) - (nodeID-of-property-or-child (getf y :elem))))))) - - - -(defun make-isidorus-occurrences (owner-elem owner-topic tm-id start-revision - &key (owner-xml-base nil) - (document-id *document-id*)) - "Creates all occurrences of resource nodes that are in a - property isidorus:occurrence and have the type isidorus:Occurrence." - (declare (dom:element owner-elem)) - (declare (string tm-id)) - (declare (TopicC owner-topic)) - (let ((content (child-nodes-or-text owner-elem :trim t)) - (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) - (err-pref "From make-isidorus-occurrence(): ")) - (when (and (not (stringp content)) - (> (length content) 0)) - (loop for property across content - when (isidorus-type-p property tm-id 'occurrence - :parent-xml-base owner-xml-base) - collect - (let ((xml-base (get-xml-base property - :old-base owner-xml-base))) - (let ((nodes - (let ((nodeID (nodeID-of-property-or-child property))) - (if nodeID - (get-all-isidorus-nodes-by-id - nodeID root *tm2rdf-occurrence-type-uri*) - (list (self-or-child-node - property *tm2rdf-occurrence-type-uri* - :xml-base xml-base)))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (occurrence-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-occurrencetype-property* - :document-id document-id)) - (value-and-datatype (make-value nodes tm-id)) - (occurrence-scopes (make-scopes nodes tm-id start-revision - :document-id document-id))) - (unless occurrence-type - (error "~aoccurrencetype is missing!" - err-pref)) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic owner-topic - :themes occurrence-scopes - :item-identifiers item-identities - :instance-of occurrence-type - :charvalue (getf value-and-datatype :value) - :datatype (getf value-and-datatype - :datatype))))))))) - - -(defun make-isidorus-names (owner-elem owner-topic tm-id start-revision - &key (owner-xml-base nil) - (document-id *document-id*)) - "Creates all names of resource nodes that are in a property isidorus:name - and have the type isidorus:Name." - (declare (dom:element owner-elem)) - (declare (string tm-id)) - (declare (TopicC owner-topic)) - (let ((content (child-nodes-or-text owner-elem :trim t)) - (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) - (err-pref "From make-isidorus-name(): ")) - (when (and (not (stringp content)) - (> (length content) 0)) - (loop for property across content - when (isidorus-type-p property tm-id 'name - :parent-xml-base owner-xml-base) - collect - (let ((xml-base (get-xml-base property - :old-base owner-xml-base))) - (let ((nodes - (let ((nodeID (nodeID-of-property-or-child property))) - (if nodeID - (get-all-isidorus-nodes-by-id - nodeID root *tm2rdf-name-type-uri*) - (list (self-or-child-node - property *tm2rdf-name-type-uri* - :xml-base xml-base)))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (name-type (import-topic-of-property - nodes tm-id start-revision - *tm2rdf-nametype-property* - :document-id document-id)) - (name-value (getf (make-value nodes tm-id) :value)) - (name-scopes (make-scopes nodes tm-id start-revision - :document-id document-id))) - (unless name-type - (error "~anametype is missing!" - err-pref)) - (let ((this - (make-construct 'NameC - :start-revision start-revision - :topic owner-topic - :charvalue name-value - :instance-of name-type - :item-identifiers item-identities - :themes name-scopes))) - (make-isidorus-variants nodes this tm-id start-revision - :document-id document-id))))))))) - - -(defun make-isidorus-variants (name-nodes owner-name tm-id start-revision - &key (document-id *document-id*)) - "Creates name variants of the passed name-nodes." - (declare (NameC owner-name)) - (declare (string tm-id)) - (let ((root - (when name-nodes - (elt (dom:child-nodes - (dom:owner-document (getf (first name-nodes) :elem))) 0))) - (err-pref "From make-isidorus-variant(): ")) - (remove-if - #'null - (loop for name-node in name-nodes - collect (let ((content (child-nodes-or-text (getf name-node :elem)))) - (when (and (not (stringp content)) - (> (length content) 0)) - (loop for property across content - when (isidorus-type-p - property tm-id 'variant - :parent-xml-base (getf name-node :xml-base)) - collect - (let ((nodes - (let ((nodeID - (get-ns-attribute property "nodeID"))) - (if nodeID - (get-all-isidorus-nodes-by-id - nodeID root *tm2rdf-name-type-uri*) - (list (self-or-child-node - property - *tm2rdf-variant-type-uri* - :xml-base - (get-xml-base - property - :old-base - (getf name-node :xml-base)))))))) - (let ((item-identities - (make-isidorus-identifiers - (map 'list #'(lambda(x) - (getf x :elem)) - nodes) start-revision)) - (variant-scopes - (append - (make-scopes nodes tm-id start-revision - :document-id document-id) - (themes owner-name))) ;XTM 2.0: 4.12 - (value-and-type (make-value nodes tm-id))) - (unless variant-scopes - (error "~ascope is missing!" - err-pref)) - (make-construct 'VariantC - :start-revision start-revision - :item-identifiers item-identities - :themes variant-scopes - :charvalue - (getf value-and-type :value) - :datatype - (getf value-and-type :datatype) - :name owner-name)))))))))) - - -(defun make-scopes (node-list tm-id start-revision - &key (document-id *document-id*)) - "Creates for every found scope a corresponding topic stub." - (let ((scopes - (remove-if - #'null - (loop for node in node-list - append - (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-scope-property*)) - collect - (let ((nodeID (get-ns-attribute property "nodeID")) - (resource (get-absolute-attribute - property tm-id (getf node :xml-base) - "resource")) - (children (child-nodes-or-text property - :trim t)) - (parseType (let ((pT - (get-ns-attribute property - "parseType"))) - (string= pT "Resource"))) - (type (get-ns-attribute property "type"))) - (if (or parseType type) - (progn - (parse-property property "") - (import-arc property tm-id start-revision - :document-id document-id - :xml-base (getf node :xml-base) - :xml-lang (getf node :xml-lang))) - (if (or nodeID resource) - (with-tm (start-revision document-id tm-id) - (make-topic-stub resource nil nodeID nil - start-revision xml-importer::tm - :document-id document-id)) - (if (and (= (length children) 1) - (not (stringp children))) - (import-node (elt children 0) tm-id - start-revision - :document-id document-id - :xml-base - (get-xml-base - (elt children 0) - :old-base (getf node :xml-base)) - :xml-lang - (get-xml-lang - (elt children 0) - :old-lang (getf node :xml-lang))) - (error "From make-scopes(): scope-property must contain one resource!"))))))))))) - (remove-duplicates scopes))) - - -(defun make-value (node-list tm-id) - "Returns the literal value of a property of the type isidorus:value." - (let ((property - (loop for node in node-list - when (or (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-value-property*)) - return property)) - (get-ns-attribute (getf node :elem) - "value" :ns-uri *tm2rdf-ns*)) - return (or (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-value-property*)) - return property)) - (get-ns-attribute (getf node :elem) - "value" :ns-uri *tm2rdf-ns*))))) - (if property - (if (stringp property) - (list :value property :datatype *xml-string*) - (let ((prop-content (child-nodes-or-text property)) - (type (let ((dt - (get-datatype - property tm-id - (find-if #'(lambda(x) - (eql property (getf x :elem))) - node-list)))) - (if dt dt *xml-string*)))) - (cond - ((= (length prop-content) 0) - (list :value "" :datatype type)) - ((not (stringp prop-content)) ;must be an element - (let ((text-val "")) - (when (dom:child-nodes property) - (loop for content-node across - (dom:child-nodes property) - do (push-string - (node-to-string content-node) - text-val))) - (list :value text-val :datatype type))) - (t (list :value prop-content :datatype type))))) - (list :value "" :datatype *xml-string*)))) - - - -(defun import-topic-of-property (node-list tm-id start-revision uri-of-property - &key (document-id *document-id*)) - "Creates a topic stub that is the type of the name represented by the - passed nodes." - (let ((err-pref "From import-topic-of-property(): ")) - (let ((tops - (loop for node in node-list - when (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - uri-of-property)) - return property)) - append - (let ((content (child-nodes-or-text (getf node :elem) - :trim t))) - (loop for property across content - when (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property))) - (string= (concatenate-uri prop-ns prop-name) - uri-of-property)) - collect - (let ((nodeID (get-ns-attribute property "nodeID")) - (resource (get-absolute-attribute - property tm-id (getf node :xml-base) - "resource")) - (children (child-nodes-or-text property - :trim t)) - (parseType (let ((pT - (get-ns-attribute property - "parseType"))) - (string= pT "Resource"))) - (type (get-ns-attribute property "type"))) - (if (or parseType type) - (progn - (parse-property (getf node :elem) "") - (import-arc property tm-id start-revision - :document-id document-id - :xml-base (getf node :xml-base) - :xml-lang (getf node :xml-lang))) - (if (or nodeID resource) - (with-tm (start-revision document-id tm-id) - (make-topic-stub resource nil nodeID nil - start-revision xml-importer::tm - :document-id document-id)) - (if (and (= (length children) 1) - (not (stringp children))) - (import-node (elt children 0) tm-id - start-revision - :document-id document-id - :xml-base - (get-xml-base - (elt children 0) - :old-base (getf node :xml-base)) - :xml-lang - (get-xml-lang - (elt children 0) - :old-lang (getf node :xml-lang))) - (error "~aproperty must contain one resource!" - err-pref)))))))))) - (if (> (length (remove-duplicates tops)) 1) - (error "~aproperty must contain one resource node: ~a!" - err-pref (length (remove-duplicates tops))) - (first tops))))) + + (let ((literals (append (get-literals-of-node elem fn-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)) + (super-classes + (get-super-classes-of-node-content elem tm-id xml-base))) + (with-tm (start-revision document-id tm-id) + (let ((this + (make-topic-stub + about ID nodeID UUID start-revision xml-importer::tm + :document-id document-id))) + (make-literals this literals tm-id start-revision + :document-id document-id) + (make-associations this associations xml-importer::tm + start-revision :document-id document-id) + (make-types this types xml-importer::tm start-revision + :document-id document-id) + (make-super-classes this super-classes xml-importer::tm + 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))))))

(defun import-arc (elem tm-id start-revision @@ -625,8 +134,8 @@ "Imports a property that is an blank_node and continues the recursion on this element." (declare (dom:element elem)) - (format t ">> import-arc: ~a <<~%" (dom:node-name elem)) ;TODO: remove (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) + (fn-xml-base (get-xml-base elem :old-base xml-base)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (parseType (get-ns-attribute elem "parseType")) (content (child-nodes-or-text elem :trim t))) @@ -641,53 +150,39 @@ (string/= parseType "Collection"))) (when UUID (parse-properties-of-node elem UUID) - (let ((subject-identifiers - (make-isidorus-identifiers - (list elem) start-revision :what "subjectIdentifier")) - (item-identities - (make-isidorus-identifiers (list elem) start-revision)) - (subject-locators - (make-isidorus-identifiers (list elem) start-revision - :what "subjectLocator"))) - (let ((this - (make-topic-stub - nil nil nil UUID start-revision xml-importer::tm - :additional-subject-identifiers - subject-identifiers - :item-identifiers item-identities - :subject-locators subject-locators - :document-id document-id))) - (let ((literals - (append (get-literals-of-property - elem fn-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-property - elem tm-id - :parent-xml-base xml-base)) - (super-classes - (get-super-classes-of-node-content - elem tm-id xml-base))) - (make-isidorus-names elem this tm-id start-revision - :owner-xml-base xml-base - :document-id document-id) - (make-isidorus-occurrences - elem this tm-id start-revision - :owner-xml-base xml-base :document-id document-id) - (make-literals this literals tm-id start-revision - :document-id document-id) - (make-associations - this associations xml-importer::tm - start-revision :document-id document-id) - (make-types this types xml-importer::tm start-revision - :document-id document-id) - (make-super-classes - this super-classes xml-importer::tm - start-revision :document-id document-id)) - this)))))) + (let ((this + (get-item-by-id UUID :xtm-id document-id + :revision start-revision))) + (let ((literals + (append (get-literals-of-property + elem fn-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 + (remove-if + #'null + (append + (get-types-of-node-content elem tm-id fn-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))) + (make-literals this literals tm-id start-revision + :document-id document-id) + (make-associations this associations xml-importer::tm + start-revision :document-id document-id) + (make-types this types xml-importer::tm start-revision + :document-id document-id) + (make-super-classes + this super-classes xml-importer::tm + start-revision :document-id document-id)) + this))))) (make-recursion-from-arc elem tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang) @@ -769,7 +264,7 @@ (map 'list #'(lambda(literal) (make-occurrence owner-top literal start-revision tm-id :document-id document-id)) - (filter-isidorus-literals literals))) + literals))

(defun make-associations (owner-top associations tm start-revision @@ -787,24 +282,21 @@ (defun make-types (owner-top types tm start-revision &key (document-id *document-id*)) "Creates instance-of associations corresponding to the passed - topic owner-top and the passed types but not isidorus:Topic." + topic owner-top and the passed types." (declare (d:TopicC owner-top)) - (remove-if - #'null - (map 'list - #'(lambda(type) - (when (string/= (getf type :psi) *tm2rdf-topic-type-uri*) - (let ((type-topic - (make-topic-stub (getf type :psi) - nil - (getf type :topicid) - nil start-revision tm - :document-id document-id)) - (ID (getf type :ID))) - (make-instance-of-association owner-top type-topic - ID start-revision tm - :document-id document-id)))) - types))) + (map 'list + #'(lambda(type) + (let ((type-topic + (make-topic-stub (getf type :psi) + nil + (getf type :topicid) + nil start-revision tm + :document-id document-id)) + (ID (getf type :ID))) + (make-instance-of-association owner-top type-topic + ID start-revision tm + :document-id document-id))) + types))

(defun make-super-classes (owner-top super-classes tm start-revision @@ -833,36 +325,40 @@ "Creates an supertype-subtype association." (declare (TopicC sub-top super-top)) (declare (TopicMapC tm)) - (let ((assoc-type - (make-topic-stub *supertype-subtype-psi* nil nil nil - start-revision tm :document-id document-id)) - (role-type-1 - (make-topic-stub *supertype-psi* nil nil nil - start-revision tm :document-id document-id)) - (role-type-2 - (make-topic-stub *subtype-psi* nil nil nil - start-revision tm :document-id document-id)) - (err-pref "From make-supertype-subtype-association(): ")) - (unless assoc-type - (error "~athe association type ~a is missing!" - err-pref *supertype-subtype-psi*)) - (unless (or role-type-1 role-type-2) - (error "~aone of the role types ~a ~a is missing!" - err-pref *supertype-psi* *subtype-psi*)) - (let ((a-roles (list (list :instance-of role-type-1 - :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)) - (add-to-topicmap - tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of assoc-type - :roles a-roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((assoc-type + (make-topic-stub *supertype-subtype-psi* nil nil nil + start-revision tm :document-id document-id)) + (role-type-1 + (make-topic-stub *supertype-psi* nil nil nil + start-revision tm :document-id document-id)) + (role-type-2 + (make-topic-stub *subtype-psi* nil nil nil + start-revision tm :document-id document-id)) + (err-pref "From make-supertype-subtype-association(): ")) + (unless assoc-type + (error "~athe association type ~a is missing!" + err-pref *supertype-subtype-psi*)) + (unless (or role-type-1 role-type-2) + (error "~aone of the role types ~a ~a is missing!" + err-pref *supertype-psi* *subtype-psi*)) + (let ((a-roles (list (list :instance-of role-type-1 + :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)) + (let ((assoc + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles)))) + (format t "a") + assoc)))))

(defun make-instance-of-association (instance-top type-top reifier-id @@ -871,42 +367,44 @@ "Creates and returns an instance-of association." (declare (TopicC type-top instance-top)) (declare (TopicMapC tm)) - (let ((assoc-type - (make-topic-stub *type-instance-psi* nil nil nil - start-revision tm :document-id document-id)) - (roletype-1 - (make-topic-stub *type-psi* nil nil nil - start-revision tm :document-id document-id)) - (roletype-2 - (make-topic-stub *instance-psi* nil nil nil - start-revision tm :document-id document-id)) - (err-pref "From make-instance-of-association(): ")) - (unless assoc-type - (error "~athe association type ~a is missing!" - err-pref *type-instance-psi*)) - (unless (or roletype-1 roletype-2) - (error "~aone of the role types ~a ~a is missing!" - err-pref *type-psi* *instance-psi*)) - (let ((a-roles (list (list :instance-of roletype-1 - :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)) - (add-to-topicmap - tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of assoc-type - :roles a-roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((assoc-type + (make-topic-stub *type-instance-psi* nil nil nil + start-revision tm :document-id document-id)) + (roletype-1 + (make-topic-stub *type-psi* nil nil nil + start-revision tm :document-id document-id)) + (roletype-2 + (make-topic-stub *instance-psi* nil nil nil + start-revision tm :document-id document-id)) + (err-pref "From make-instance-of-association(): ")) + (unless assoc-type + (error "~athe association type ~a is missing!" + err-pref *type-instance-psi*)) + (unless (or roletype-1 roletype-2) + (error "~aone of the role types ~a ~a is missing!" + err-pref *type-psi* *instance-psi*)) + (let ((a-roles (list (list :instance-of roletype-1 + :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)) + (let ((assoc + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles)))) + (format t "a") + assoc)))))

(defun make-topic-stub (about ID nodeId UUID start-revision - tm &key (document-id *document-id*) - (additional-subject-identifiers nil) - (item-identifiers nil) (subject-locators nil)) + tm &key (document-id *document-id*)) "Returns a topic corresponding to the passed parameters. When the searched topic does not exist there will be created one. If about or ID is set there will also be created a new PSI." @@ -914,40 +412,47 @@ (let ((topic-id (or about ID nodeID UUID)) (psi-uri (or about ID))) (let ((top - ;seems like there is a bug in get-item-by-id: + ;seems like there is a bug in d:get-item-by-id: ;this functions returns an emtpy topic although there is no one - ;witha corresponding topic id and/or version and/or xtm-id + ;with a corresponding topic id and/or version and/or xtm-id (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))) + (find-if #'(lambda(x) + (= (d::start-revision x) start-revision)) + (d::versions inner-top))) inner-top)))) (if top top - (let ((psis (if psi-uri - (remove-if - #'null - (append - (list - (make-instance 'PersistentIdC - :uri psi-uri - :start-revision start-revision)) - additional-subject-identifiers)) - additional-subject-identifiers))) - (handler-case (add-to-topicmap - tm - (make-construct 'TopicC - :topicid topic-id - :psis psis - :item-identifiers item-identifiers - :locators subject-locators - :xtm-id document-id - :start-revision start-revision)) - (Condition (err)(error "Creating topic ~a failed: ~a" - topic-id err)))))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((psis (when psi-uri + (list + (make-instance 'PersistentIdC + :uri psi-uri + :start-revision start-revision))))) + (handler-case (let ((top + (add-to-topicmap + tm + (make-construct + 'TopicC + :topicid topic-id + :psis psis + :xtm-id document-id + :start-revision start-revision)))) + (format t "t") + top) + (Condition (err)(error "Creating topic ~a failed: ~a" + topic-id err)))))))))

(defun make-lang-topic (lang start-revision tm @@ -975,28 +480,32 @@ (player-id (getf association :topicid)) (player-psi (getf association :psi)) (ID (getf association :ID))) - (let ((player-1 (make-topic-stub player-psi nil player-id nil - start-revision - tm :document-id document-id)) - (role-type-1 - (make-topic-stub *rdf2tm-object* nil nil nil - start-revision tm :document-id document-id)) - (role-type-2 - (make-topic-stub *rdf2tm-subject* nil nil nil - start-revision tm :document-id document-id)) - (type-top (make-topic-stub type nil nil nil start-revision - tm :document-id document-id))) - (let ((roles (list (list :instance-of role-type-1 - :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)) - (add-to-topicmap tm (make-construct 'AssociationC - :start-revision start-revision - :instance-of type-top - :roles roles)))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((player-1 (make-topic-stub player-psi nil player-id nil + start-revision + tm :document-id document-id)) + (role-type-1 + (make-topic-stub *rdf2tm-object* nil nil nil + start-revision tm :document-id document-id)) + (role-type-2 + (make-topic-stub *rdf2tm-subject* nil nil nil + start-revision tm :document-id document-id)) + (type-top (make-topic-stub type nil nil nil start-revision + tm :document-id document-id))) + (let ((roles (list (list :instance-of role-type-1 + :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)) + (let ((assoc + (add-to-topicmap tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of type-top + :roles roles)))) + (format t "a") + assoc))))))

(defun make-association-with-nodes (subject-topic object-topic @@ -1005,20 +514,25 @@ "Creates an association with two roles that contains the given players." (declare (TopicC subject-topic object-topic associationtype-topic)) (declare (TopicMapC tm)) - (let ((role-type-1 - (make-topic-stub *rdf2tm-subject* nil nil nil start-revision - tm :document-id document-id)) - (role-type-2 - (make-topic-stub *rdf2tm-object* nil nil nil start-revision - tm :document-id document-id))) - (let ((roles (list (list :instance-of role-type-1 - :player subject-topic) - (list :instance-of role-type-2 - :player object-topic)))) - (add-to-topicmap tm (make-construct 'AssociationC - :start-revision start-revision - :instance-of associationtype-topic - :roles roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((role-type-1 + (make-topic-stub *rdf2tm-subject* nil nil nil start-revision + tm :document-id document-id)) + (role-type-2 + (make-topic-stub *rdf2tm-object* nil nil nil start-revision + tm :document-id document-id))) + (let ((roles (list (list :instance-of role-type-1 + :player subject-topic) + (list :instance-of role-type-2 + :player object-topic)))) + (let ((assoc + (add-to-topicmap + tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of associationtype-topic + :roles roles)))) + (format t "a") + assoc)))))

(defun make-reification (reifier-id subject object predicate start-revision tm @@ -1028,34 +542,36 @@ (declare ((or OccurrenceC TopicC) object)) (declare (TopicC subject predicate)) (declare (TopicMapC tm)) - - (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 + (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)) - (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))))) + (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 @@ -1070,32 +586,33 @@ (lang (getf literal :lang)) (datatype (getf literal :datatype)) (ID (getf literal :ID))) - (let ((type-top (make-topic-stub type nil nil nil start-revision - xml-importer::tm - :document-id document-id)) - (lang-top (make-lang-topic lang start-revision - xml-importer::tm - :document-id document-id))) - (let ((occurrence - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes (when lang-top - (list lang-top)) - :instance-of type-top - :charvalue value - :datatype datatype))) - (when ID - (make-reification ID top occurrence type-top start-revision - xml-importer::tm :document-id document-id)) - occurrence))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((type-top (make-topic-stub type nil nil nil start-revision + xml-importer::tm + :document-id document-id)) + (lang-top (make-lang-topic lang start-revision + xml-importer::tm + :document-id document-id))) + (let ((occurrence + (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes (when lang-top + (list lang-top)) + :instance-of type-top + :charvalue value + :datatype datatype))) + (when ID + (make-reification ID top occurrence type-top start-revision + xml-importer::tm :document-id document-id)) + occurrence))))))

(defun get-literals-of-node-content (node tm-id xml-base 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 (non-isidorus-child-nodes-or-text node :trim t)) + (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))) (let ((literals @@ -1164,8 +681,8 @@ :ID nil)) nil)) (content-types - (when (non-isidorus-child-nodes-or-text node :trim t) - (loop for child across (non-isidorus-child-nodes-or-text node :trim t) + (when (child-nodes-or-text node :trim t) + (loop for child across (child-nodes-or-text node :trim t) when (and (string= (dom:namespace-uri child) *rdf-ns*) (string= (get-node-name child) "type")) collect (let ((nodeID (get-ns-attribute child "nodeID")) @@ -1279,7 +796,7 @@ "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 (non-isidorus-child-nodes-or-text node :trim t)) + (let ((content (child-nodes-or-text node :trim t)) (fn-xml-base (get-xml-base node :old-base xml-base))) (when content (loop for property across content @@ -1312,7 +829,7 @@ (defun get-associations-of-node-content (node tm-id xml-base) "Returns a list of associations with a type, value and ID member." (declare (dom:element node)) - (let ((properties (non-isidorus-child-nodes-or-text node :trim t)) + (let ((properties (child-nodes-or-text node :trim t)) (fn-xml-base (get-xml-base node :old-base xml-base))) (loop for property across properties when (let ((prop-name (get-node-name property)) @@ -1372,7 +889,7 @@ "Calls the next function that handles all DOM child elements of the passed element as arcs." (declare (dom:element node)) - (let ((content (non-isidorus-child-nodes-or-text node :trim t)) + (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))) @@ -1391,7 +908,7 @@ (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)) - (content (non-isidorus-child-nodes-or-text arc)) + (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")) @@ -1423,55 +940,4 @@ collect (import-node item tm-id start-revision :document-id document-id :xml-base xml-base - :xml-lang xml-lang)))))))) - - -(defun make-isidorus-identifiers (owner-list start-revision &key (what "itemIdentity")) - "Returns a list oc created identifier objects that can be - used directly in make-topic-stub." - (declare (string what)) - (when (and (string/= what "itemIdentity") - (string/= what "subjectIdentifier") - (string/= what "subjectLocator")) - (error "From make-identifiers(): what must be set to: ~a but is ~a" - (list "itemIdentity" "subjectIdentifiers" "subjectLocator") - what)) - (let ((class-symbol - (cond - ((string= what "itemIdentity") - 'ItemIdentifierC) - ((string= what "subjectIdentifier") - 'PersistentIdC) - ((string= what "subjectLocator") - 'SubjectLocatorC)))) - (let ((uris - (loop for owner-elem in owner-list - append - (let ((content (child-nodes-or-text owner-elem :trim t))) - (unless (stringp content) - (let ((identifier-uris - (loop for property across content - when - (let ((prop-ns (dom:namespace-uri property)) - (prop-name (get-node-name property)) - (prop-content (child-nodes-or-text - property :trim t))) - (and (string= prop-ns *tm2rdf-ns*) - (string= prop-name what) - (stringp prop-content) - (> (length prop-content) 0))) - collect - (child-nodes-or-text property :trim t))) - (attr-uri - (let ((attr (get-ns-attribute owner-elem what - :ns-uri *tm2rdf-ns*))) - (when attr - (list attr))))) - (append identifier-uris attr-uri))))))) - (map 'list #'(lambda(x) - (make-instance class-symbol - :uri x - :start-revision start-revision)) - (remove-duplicates - (remove-if #'null uris) - :test #'string=))))) \ No newline at end of file + :xml-lang xml-lang)))))))) \ No newline at end of file

Added: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- (empty file) +++ trunk/src/xml/rdf/map_to_tm.lisp Sat Sep 5 11:53:27 2009 @@ -0,0 +1,77 @@ +;;+----------------------------------------------------------------------------- +;;+ 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. +;;+----------------------------------------------------------------------------- +(in-package :rdf-importer) + +(defun map-to-tm (tm-id start-revision + &key (document-id *document-id*)) + (let ((topics-to-map (get-isi-topics tm-id start-revision + :document-id document-id))) + )) + + +(defun get-isi-topics (tm-id start-revision + &key (document-id *document-id*)) + "Returns all topics of the given tm and revision." + (let ((isi-topic-type (get-item-by-id *tm2rdf-topic-type-uri* + :xtm-id document-id + :revision start-revision)) + (type-instance (get-item-by-psi *type-instance-psi* + :revision start-revision)) + (instance (get-item-by-psi *instance-psi* + :revision start-revision))) + (when (and isi-topic-type type-instance instance) + (with-revision start-revision + (let ((type-associations + (remove-if #'null + (map 'list + #'(lambda(role) + (when (eql (instance-of (parent role)) + type-instance) + (parent role))) + (player-in-roles isi-topic-type))))) + (let ((instances + (remove-if #'null + (map 'list + #'(lambda(assoc) + (let ((role + (find-if #'(lambda(role) + (eql (instance-of role) + instance)) + (roles assoc)))) + (when role + (player role)))) + type-associations)))) + (let ((instances-of-tm + (with-tm (start-revision document-id tm-id) + (intersection (topics xml-importer::tm) instances)))) + (remove-if #'null + (map 'list + #'(lambda(x) + (find-item-by-revision x start-revision)) + instances-of-tm))))))))) + + +(defun map-isi-identifiers (top start-revision + &key (prop-uri *tm2rdf-itemIdentity-property*)) + (declare (TopicC top)) + (with-revision start-revision + (let ((identifier-occs + (remove-if #'null + (map 'list + #'(lambda(occurrence) + (let ((type (instance-of occurrence))) + (let ((type-psi + (find-if #'(lambda(psi) + (string= prop-uri + (uri psi))) + (psis type)))) + (format t "~a~%" type-psi) + (when type-psi + occurrence)))) + (occurrences top))))) + identifier-occs))) \ 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 Sat Sep 5 11:53:27 2009 @@ -45,16 +45,7 @@ *tm2rdf-association-property* *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* - *tm2rdf-subjectLocator-property* - *tm2rdf-ns* - *tm2rdf-value-property* - *tm2rdf-nametype-property* - *tm2rdf-scope-property* - *tm2rdf-varianttype-property* - *tm2rdf-occurrencetype-property* - *tm2rdf-roletype-property* - *tm2rdf-associationtype-property* - *tm2rdf-player-property*) + *tm2rdf-subjectLocator-property*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) @@ -92,7 +83,8 @@ (:export :setup-rdf-module :rdf-importer :init-rdf-module - :*rdf-core-xtm*)) + :*rdf-core-xtm* + :*document-id*))

(in-package :rdf-importer)

@@ -113,6 +105,8 @@

(defvar *_n-map* nil)

+(defvar *document-id* "isidorus-rdf-document") +

(defun _n-p (node) "Returns t if the given value is of the form _[0-9]+" @@ -299,29 +293,6 @@ :psi (or ID about)))))))

-(defun get-ref-of-property (property-elem tm-id xml-base) - "Returns a plist of the form (:topicid <string> :psi <string>). - That contains the property's value." - (declare (dom:element property-elem)) - (declare (string tm-id)) - (let ((nodeId (get-ns-attribute property-elem "nodeID")) - (resource (get-ns-attribute property-elem "resource")) - (content (let ((node-refs - (get-node-refs (child-nodes-or-text property-elem) - tm-id xml-base))) - (when node-refs - (first node-refs))))) - (cond - (nodeID - (list :topicid nodeID - :psi nil)) - (resource - (list :topicid resource - :psi resource)) - (content - content)))) - - (defun parse-property-name (property owner-identifier) "Parses the given property's name to the known rdf/rdfs nodes and arcs. If the given name es equal to an node an error is thrown otherwise @@ -531,18 +502,3 @@ :psi (get-type-of-node-name elem) :ID nil))) (get-types-of-node-content elem tm-id xml-base))))) - - -(defun get-types-of-property (elem tm-id &key (parent-xml-base nil)) - "Returns a plist of all property'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 - (get-types-of-node-content elem tm-id xml-base) - (when (get-ns-attribute elem "type") - (list :ID nil - :topicid (get-ns-attribute elem "type") - :psi (get-ns-attribute elem "type"))))))) - -