isidorus-cvs September 2009

isidorus-cvs@common-lisp.net

1 participants
14 discussions

[isidorus-cvs] r141 - in trunk/src: model unit_tests
by Lukas Giessmann 10 Sep '09

10 Sep '09

Author: lgiessmann Date: Thu Sep 10 06:12:47 2009 New Revision: 141 Log: datamodel: added a 1:1 elephant-assocation to ReifiableConstructC and TopicC realizing reification; extended the functions delete-construct and initialize-instance of the affected classes Modified: trunk/src/model/datamodel.lisp trunk/src/unit_tests/importer_test.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Thu Sep 10 06:12:47 2009 @@ -101,6 +101,8 @@ :variants :xor :create-latest-fragment-of-topic + :reified + :reifier :*current-xtm* ;; special variables :*TM-REVISION* @@ -372,11 +374,11 @@ (symbol-value '*TM-REVISION*)) (t 0))) (properties (slot-value construct slot-name))) - ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) + ;(format t "revision in filter-slot-value-by-revision is ~a~&" revision) (cond ((not properties) nil) ;if we don't have any properties, we don't have to worry - ;about revisions + ;about revisions ((= 0 revision) (remove nil @@ -599,26 +601,45 @@ :inherit t :documentation "Slot that realizes a 1 to N relation between reifiable constructs and their - identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs")) + identifiers; pseudo-initarg is :item-identifiers. Is inherited by all reifiable constructs") + (reifier + :associate TopicC + :inherit t + :documentation "Represents a reifier association to a topic, i.e. + it stands for a 1:1 association between this class and TopicC")) (:documentation "Reifiable constructs as per TMDM")) + +(defgeneric reifier (construct &key revision) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (when (slot-boundp construct 'reifier) + (filter-slot-value-by-revision construct 'reifier :start-revision revision)))) + +(defgeneric (setf reifier) (topic TopicC) + (:method (topic (construct ReifiableConstructC)) + (setf (slot-value construct 'reifier) topic) + (setf (reified topic) construct))) + (defgeneric item-identifiers (construct &key revision) (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) -(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil)) +(defmethod initialize-instance :around ((instance ReifiableConstructC) &key (item-identifiers nil) (reifier nil)) "adds associations to these ids after the instance was initialized." (declare (list item-identifiers)) (call-next-method) (dolist (id item-identifiers) (declare (ItemIdentifierC id)) (setf (identified-construct id) instance)) + (when reifier + (setf (reifier instance) reifier)) instance) - (defmethod delete-construct :before ((construct ReifiableConstructC)) (dolist (id (item-identifiers construct)) - (delete-construct id))) + (delete-construct id)) + (when (reifier construct) + (slot-makunbound (reifier construct) 'reified))) (defgeneric item-identifiers-p (constr) (:documentation "Test for the existence of item identifiers") @@ -928,9 +949,23 @@ (in-topicmaps :associate (TopicMapC topics) :many-to-many t - :documentation "list of all topic maps this topic is part of")) + :documentation "list of all topic maps this topic is part of") + (reified + :associate ReifiableConstructC + :documentation "contains a reified object, represented as 1:1 association")) (:documentation "Topic in a Topic Map")) + +(defgeneric reified (topic &key revision) + (:method ((topic TopicC) &key (revision *TM-REVISION*)) + (when (slot-boundp topic 'reified) + (filter-slot-value-by-revision topic 'reified :start-revision revision)))) + +(defgeneric (setf reified) (reifiable ReifiableConstructC) + (:method (reifiable (topic TopicC)) + (setf (slot-value topic 'reified) reifiable) + (setf (reifier reifiable) topic))) + (defgeneric occurrences (topic &key revision) (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'occurrences :start-revision revision))) @@ -966,19 +1001,21 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision))) -(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil)) +(defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil) (reified nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis)) (declare (list locators)) (call-next-method) - ;item-identifiers are handled in the around-method for ReifiableConstructs, - ;TopicIdentificationCs are handled in make-construct of TopicC + ;item-identifiers are handled in the around-method for ReifiableConstructs, + ;TopicIdentificationCs are handled in make-construct of TopicC (dolist (persistent-id psis) (declare (PersistentIdC persistent-id)) (setf (identified-construct persistent-id) instance)) (dolist (subject-locator locators) (declare (SubjectLocatorC subject-locator)) - (setf (identified-construct subject-locator) instance))) + (setf (identified-construct subject-locator) instance)) + (when reified + (setf (reified instance) reified))) (defmethod delete-construct :before ((construct TopicC)) @@ -993,7 +1030,9 @@ (dolist (theme (used-as-theme construct)) (elephant:remove-association construct 'used-as-theme theme)) (dolist (tm (in-topicmaps construct)) - (elephant:remove-association construct 'in-topicmaps tm))) + (elephant:remove-association construct 'in-topicmaps tm)) + (when (reified construct) + (slot-makunbound (reified construct) 'reifier))) (defun get-all-constructs-by-uri (uri) (delete Modified: trunk/src/unit_tests/importer_test.lisp ============================================================================== --- trunk/src/unit_tests/importer_test.lisp (original) +++ trunk/src/unit_tests/importer_test.lisp Thu Sep 10 06:12:47 2009 @@ -662,6 +662,5 @@ ;as (importer-test:run-importer-tests) (defun run-importer-tests () (run! 'importer-test)) -;or (it.bese.fiveam.run! )

1 0

[isidorus-cvs] r140 - trunk/src/unit_tests
by Lukas Giessmann 09 Sep '09

09 Sep '09

Author: lgiessmann Date: Wed Sep 9 03:56:23 2009 New Revision: 140 Log: unit-tests: added functions of the for run-<module-name>-tests to all unit-tests without such a function -> consiteny Modified: trunk/src/unit_tests/atom_test.lisp trunk/src/unit_tests/versions_test.lisp Modified: trunk/src/unit_tests/atom_test.lisp ============================================================================== --- trunk/src/unit_tests/atom_test.lisp (original) +++ trunk/src/unit_tests/atom_test.lisp Wed Sep 9 03:56:23 2009 @@ -28,7 +28,9 @@ duplicate-identifier-error) (:export :atom-test :test-feed-to-string - :test-collection-configuration)) + :test-collection-configuration + :test-changes-feeds + :run-atom-tests)) ;test configuration (in-package :atom-test) @@ -204,3 +206,8 @@ (mapcar #'type-of collection-entries))) ))) + +(defun run-atom-tests() + (it.bese.fiveam:run! 'test-feed-to-string) + (it.bese.fiveam:run! 'test-changes-feeds) + (it.bese.fiveam:run! 'test-collection-configuration)) \ No newline at end of file Modified: trunk/src/unit_tests/versions_test.lisp ============================================================================== --- trunk/src/unit_tests/versions_test.lisp (original) +++ trunk/src/unit_tests/versions_test.lisp Wed Sep 9 03:56:23 2009 @@ -32,7 +32,7 @@ :test-change-lists :test-changed-p :versions-test - )) + :run-versions-tests)) (declaim (optimize (debug 3))) (in-package :versions-test) @@ -363,4 +363,12 @@ :revision (1+ fixtures::revision3)))))) - \ No newline at end of file + +(defun run-versions-tests() + (it.bese.fiveam:run! 'test-get-item-by-id-t100) + (it.bese.fiveam:run! 'test-get-item-by-id-t301) + (it.bese.fiveam:run! 'test-norwegian-curriculum-association) + (it.bese.fiveam:run! 'test-instance-of-t64) + (it.bese.fiveam:run! 'test-change-lists) + (it.bese.fiveam:run! 'test-changed-p) + (it.bese.fiveam:run! 'test-mark-as-deleted)) \ No newline at end of file

1 0

[isidorus-cvs] r139 - trunk/src/xml/rdf
by Lukas Giessmann 09 Sep '09

09 Sep '09

Author: lgiessmann Date: Wed Sep 9 03:42:00 2009 New Revision: 139 Log: rdf-importer: fixed a bug with xml:base and xml:lang; renamed some parameters for a better understanding Modified: trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 9 03:42:00 2009 @@ -84,31 +84,36 @@ (let ((children (child-nodes-or-text rdf-dom :trim t))) (when children (loop for child across children - do (import-node child tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang))) + do (import-node child tm-id start-revision + :document-id document-id + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) + (import-node rdf-dom tm-id start-revision + :document-id document-id + :parent-xml-base xml-base + :parent-xml-lang xml-lang))) (setf *_n-map* nil)) (defun import-node (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) + "Imports an RDF node with all its properties and 'child' RDF nodes." (tm-id-p tm-id "import-node") (parse-node elem) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))) - (let ((about (get-absolute-attribute elem tm-id xml-base "about")) - (nodeID (get-ns-attribute elem "nodeID")) - (ID (get-absolute-attribute elem tm-id xml-base "ID")) - (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) - (parse-properties-of-node elem (or about nodeID ID UUID)) - - (let ((literals (append (get-literals-of-node elem fn-xml-lang) + (let ((about (get-absolute-attribute elem tm-id parent-xml-base "about")) + (nodeID (get-ns-attribute elem "nodeID")) + (ID (get-absolute-attribute elem tm-id parent-xml-base "ID")) + (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) + (parse-properties-of-node elem (or about nodeID ID UUID)) + (let ((literals (append (get-literals-of-node elem parent-xml-lang) (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) - (associations (get-associations-of-node-content elem tm-id xml-base)) - (types (get-types-of-node elem tm-id :parent-xml-base xml-base)) + elem tm-id parent-xml-base parent-xml-lang))) + (associations (get-associations-of-node-content elem tm-id + parent-xml-base)) + (types (get-types-of-node elem tm-id + :parent-xml-base parent-xml-base)) (super-classes - (get-super-classes-of-node-content elem tm-id xml-base))) + (get-super-classes-of-node-content elem tm-id parent-xml-base))) (with-tm (start-revision document-id tm-id) (let ((this (make-topic-stub @@ -124,19 +129,18 @@ start-revision :document-id document-id) (make-recursion-from-node elem tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) - this)))))) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) + this))))) (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Imports a property that is an blank_node and continues the recursion on this element." (declare (dom:element elem)) - (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) - (fn-xml-base (get-xml-base elem :old-base xml-base)) + (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)) (parseType (get-ns-attribute elem "parseType")) (content (child-nodes-or-text elem :trim t))) @@ -156,24 +160,26 @@ :revision start-revision))) (let ((literals (append (get-literals-of-property - elem fn-xml-lang) + elem xml-lang) (get-literals-of-node-content - elem tm-id xml-base fn-xml-lang))) + elem tm-id parent-xml-base + parent-xml-lang))) (associations (get-associations-of-node-content - elem tm-id xml-base)) + elem tm-id parent-xml-base)) (types (remove-if #'null (append - (get-types-of-node-content elem tm-id fn-xml-base) + (get-types-of-node-content elem tm-id + parent-xml-base) (when (get-ns-attribute elem "type") (list :ID nil :topicid (get-ns-attribute elem "type") :psi (get-ns-attribute elem "type")))))) (super-classes (get-super-classes-of-node-content - elem tm-id xml-base))) + elem tm-id parent-xml-base))) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations this associations xml-importer::tm @@ -186,19 +192,20 @@ this))))) (make-recursion-from-arc elem tm-id start-revision :document-id document-id - :xml-base xml-base :xml-lang xml-lang) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) this-topic))))) (defun make-collection (elem tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Creates a collection structure of a node that contains parseType='Collection." (declare (dom:element elem)) (with-tm (start-revision document-id tm-id) - (let ((fn-xml-base (get-xml-base elem :old-base xml-base)) - (fn-xml-lang (get-xml-lang elem :old-lang xml-lang)) + (let ((xml-base (get-xml-base elem :old-base parent-xml-base)) + (xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (let ((this (make-topic-stub nil nil nil UUID start-revision xml-importer::tm @@ -206,8 +213,8 @@ (items (loop for item across (child-nodes-or-text elem :trim t) collect (import-node item tm-id start-revision :document-id document-id - :xml-base fn-xml-base - :xml-lang fn-xml-lang)))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) (let ((last-blank-node this)) (dotimes (index (length items)) (let ((is-end @@ -466,10 +473,6 @@ (when lang (let ((psi-and-topic-id (concatenate-uri *rdf2tm-scope-prefix* lang))) - ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id -; :revision start-revision))) -; (if top -; top (make-topic-stub psi-and-topic-id nil nil nil start-revision tm :document-id document-id)))) @@ -612,13 +615,13 @@ occurrence)))))) -(defun get-literals-of-node-content (node tm-id xml-base xml-lang) +(defun get-literals-of-node-content (node tm-id parent-xml-base parent-xml-lang) "Returns a list of literals that is produced of a node's content." (declare (dom:element node)) (tm-id-p tm-id "get-literals-of-noode-content") (let ((properties (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base)) - (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (xml-base (get-xml-base node :old-base parent-xml-base)) + (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) (let ((literals (when properties (loop for property across properties @@ -643,11 +646,11 @@ (string/= parseType "Resource"))) collect (let ((content (child-nodes-or-text property)) (ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (child-xml-lang - (get-xml-lang property :old-lang fn-xml-lang))) + (get-xml-lang property :old-lang xml-lang))) (let ((full-name (get-type-of-node-name property)) - (datatype (get-datatype property tm-id fn-xml-base)) + (datatype (get-datatype property tm-id xml-base)) (text (cond ((= (length content) 0) @@ -670,18 +673,18 @@ literals))) -(defun get-types-of-node-content (node tm-id xml-base) +(defun get-types-of-node-content (node tm-id parent-xml-base) "Returns a list of type-uris that corresponds to the node's content or attributes." (tm-id-p tm-id "get-types-of-node-content") - (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + (let ((xml-base (get-xml-base node :old-base parent-xml-base))) (let ((attr-type (if (get-ns-attribute node "type") (list (list :topicid (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + xml-base tm-id) :psi (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + xml-base tm-id) :ID nil)) nil)) (content-types @@ -691,17 +694,17 @@ (string= (get-node-name child) "type")) collect (let ((nodeID (get-ns-attribute child "nodeID")) (resource (get-absolute-attribute - child tm-id fn-xml-base "resource")) + child tm-id xml-base "resource")) (UUID (get-ns-attribute child "UUID" :ns-uri *rdf2tm-ns*)) (ID (get-absolute-attribute child tm-id - fn-xml-base "ID"))) + xml-base "ID"))) (if (or nodeID resource UUID) (list :topicid (or nodeID resource UUID) :psi resource :ID ID) (let ((child-xml-base - (get-xml-base child :old-base fn-xml-base))) + (get-xml-base child :old-base xml-base))) (let ((refs (get-node-refs (child-nodes-or-text child :trim t) @@ -712,9 +715,9 @@ (remove-if #'null (append attr-type content-types))))) -(defun get-literals-of-property (property xml-lang) +(defun get-literals-of-property (property parent-xml-lang) "Returns a list of attributes that are treated as literal nodes." - (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang)) + (let ((xml-lang (get-xml-lang property :old-lang parent-xml-lang)) (attributes nil)) (dom:map-node-map #'(lambda(attr) @@ -737,7 +740,7 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))) ((or (string= attr-ns *xml-ns*) @@ -749,16 +752,16 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))))))) (dom:attributes property)) attributes)) -(defun get-literals-of-node (node xml-lang) +(defun get-literals-of-node (node parent-xml-lang) "Returns alist of attributes that are treated as literal nodes." - (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang)) + (let ((xml-lang (get-xml-lang node :old-lang parent-xml-lang)) (attributes nil)) (dom:map-node-map #'(lambda(attr) @@ -777,7 +780,7 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))) ((or (string= attr-ns *xml-ns*) @@ -789,19 +792,19 @@ (push (list :type l-type :value l-value :ID nil - :lang fn-xml-lang + :lang xml-lang :datatype *xml-string*) attributes))))))) (dom:attributes node)) attributes)) -(defun get-super-classes-of-node-content (node tm-id xml-base) +(defun get-super-classes-of-node-content (node tm-id parent-xml-base) "Returns a list of super-classes and IDs." (declare (dom:element node)) (tm-id-p tm-id "get-super-classes-of-node-content") (let ((content (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base))) + (xml-base (get-xml-base node :old-base parent-xml-base))) (when content (loop for property across content when (let ((prop-name (get-node-name property)) @@ -809,13 +812,13 @@ (and (string= prop-name "subClassOf") (string= prop-ns *rdfs-ns*))) collect (let ((prop-xml-base (get-xml-base property - :old-base fn-xml-base))) + :old-base xml-base))) (let ((ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (nodeID (get-ns-attribute property "nodeID")) (resource (get-absolute-attribute property tm-id - fn-xml-base "resource")) + xml-base "resource")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*))) (if (or nodeID resource UUID) @@ -830,17 +833,17 @@ :ID ID))))))))) -(defun get-associations-of-node-content (node tm-id xml-base) +(defun get-associations-of-node-content (node tm-id parent-xml-base) "Returns a list of associations with a type, value and ID member." (declare (dom:element node)) (let ((properties (child-nodes-or-text node :trim t)) - (fn-xml-base (get-xml-base node :old-base xml-base))) + (xml-base (get-xml-base node :old-base parent-xml-base))) (loop for property across properties when (let ((prop-name (get-node-name property)) (prop-ns (dom:namespace-uri property)) (prop-content (child-nodes-or-text property)) (resource (get-absolute-attribute property tm-id - fn-xml-base "resource")) + xml-base "resource")) (nodeID (get-ns-attribute property "nodeID")) (type (get-ns-attribute property "type")) (parseType (get-ns-attribute property "parseType")) @@ -858,7 +861,7 @@ (not (and (string= prop-name "subClassOf") (string= prop-ns *rdfs-ns*))))) collect (let ((prop-xml-base (get-xml-base property - :old-base fn-xml-base)) + :old-base xml-base)) (content (child-nodes-or-text property :trim t)) (parseType (get-ns-attribute property "parseType"))) (let ((resource @@ -866,12 +869,12 @@ (= (length content) 0)) *rdf-nil* (get-absolute-attribute property tm-id - fn-xml-base "resource"))) + xml-base "resource"))) (nodeID (get-ns-attribute property "nodeID")) (UUID (get-ns-attribute property "UUID" :ns-uri *rdf2tm-ns*)) (ID (get-absolute-attribute property tm-id - fn-xml-base "ID")) + xml-base "ID")) (full-name (get-type-of-node-name property))) (if (or nodeID resource UUID) (list :type full-name @@ -889,42 +892,45 @@ (defun make-recursion-from-node (node tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Calls the next function that handles all DOM child elements of the passed element as arcs." (declare (dom:element node)) (let ((content (child-nodes-or-text node :trim t)) (err-pref "From make-recursion-from-node(): ") - (fn-xml-base (get-xml-base node :old-base xml-base)) - (fn-xml-lang (get-xml-lang node :old-lang xml-lang))) + (xml-base (get-xml-base node :old-base parent-xml-base)) + (xml-lang (get-xml-lang node :old-lang parent-xml-lang))) (when (stringp content) (error "~aliteral content not allowed here: ~a" err-pref content)) (loop for arc across content collect (import-arc arc tm-id start-revision :document-id document-id - :xml-base fn-xml-base :xml-lang fn-xml-lang)))) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))) (defun make-recursion-from-arc (arc tm-id start-revision &key (document-id *document-id*) - (xml-base nil) (xml-lang nil)) + (parent-xml-base nil) (parent-xml-lang nil)) "Calls the next function that handles the arcs content nodes/arcs." (declare (dom:element arc)) - (let ((fn-xml-base (get-xml-base arc :old-base xml-base)) - (fn-xml-lang (get-xml-lang arc :old-lang xml-lang)) + (let ((xml-base (get-xml-base arc :old-base parent-xml-base)) + (xml-lang (get-xml-lang arc :old-lang parent-xml-lang)) (content (child-nodes-or-text arc)) (parseType (get-ns-attribute arc "parseType"))) - (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype")) - (type (get-absolute-attribute arc tm-id xml-base "type")) - (resource (get-absolute-attribute arc tm-id xml-base "resource")) + (let ((datatype (get-absolute-attribute arc tm-id + parent-xml-base "datatype")) + (type (get-absolute-attribute arc tm-id parent-xml-base "type")) + (resource (get-absolute-attribute arc tm-id + parent-xml-base "resource")) (nodeID (get-ns-attribute arc "nodeID")) - (literals (get-literals-of-property arc xml-lang))) + (literals (get-literals-of-property arc parent-xml-lang))) (if (and parseType (string= parseType "Collection")) (make-collection arc tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang) + :parent-xml-base parent-xml-base + :parent-xml-lang parent-xml-lang) (if (or datatype resource nodeID (and parseType (string= parseType "Literal")) @@ -938,10 +944,10 @@ (loop for item across content collect (import-arc item tm-id start-revision :document-id document-id - :xml-base fn-xml-base - :xml-lang fn-xml-lang)) + :parent-xml-base xml-base + :parent-xml-lang xml-lang)) (loop for item across content collect (import-node item tm-id start-revision :document-id document-id - :xml-base xml-base - :xml-lang xml-lang)))))))) \ No newline at end of file + :parent-xml-base xml-base + :parent-xml-lang xml-lang)))))))) \ No newline at end of file Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 9 03:42:00 2009 @@ -282,21 +282,21 @@ t) -(defun get-node-refs (nodes tm-id xml-base) +(defun get-node-refs (nodes tm-id parent-xml-base) "Returns a list of node references that can be used as topic IDs." (when (and nodes (> (length nodes) 0)) (loop for node across nodes - collect (let ((fn-xml-base (get-xml-base node :old-base xml-base))) + collect (let ((xml-base (get-xml-base node :old-base parent-xml-base))) (parse-node node) (let ((ID (when (get-ns-attribute node "ID") (absolutize-id (get-ns-attribute node "ID") - fn-xml-base tm-id))) + xml-base tm-id))) (nodeID (get-ns-attribute node "nodeID")) (about (when (get-ns-attribute node "about") (absolutize-value (get-ns-attribute node "about") - fn-xml-base tm-id))) + xml-base tm-id))) (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*))) (list :topicid (or ID about nodeID UUID) :psi (or ID about))))))) @@ -465,29 +465,28 @@ t) -(defun get-absolute-attribute (elem tm-id xml-base attr-name +(defun get-absolute-attribute (elem tm-id parent-xml-base attr-name &key (ns-uri *rdf-ns*)) "Returns an absolute 'attribute' or nil." (declare (dom:element elem)) (declare (string attr-name)) (tm-id-p tm-id "get-ID") (let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri)) - (fn-xml-base (get-xml-base elem :old-base xml-base))) + (xml-base (get-xml-base elem :old-base parent-xml-base))) (when attr (if (and (string= ns-uri *rdf-ns*) (string= attr-name "ID")) - (absolutize-id attr fn-xml-base tm-id) - (absolutize-value attr fn-xml-base tm-id))))) + (absolutize-id attr xml-base tm-id) + (absolutize-value attr xml-base tm-id))))) -(defun get-datatype (elem tm-id xml-base) +(defun get-datatype (elem tm-id parent-xml-base) "Returns a datatype value. The default is xml:string." - (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) - (let ((datatype - (get-absolute-attribute elem tm-id fn-xml-base "datatype"))) - (if datatype - datatype - *xml-string*)))) + (let ((datatype + (get-absolute-attribute elem tm-id parent-xml-base "datatype"))) + (if datatype + datatype + *xml-string*))) (defun tm-id-p (tm-id fun-name) @@ -500,14 +499,13 @@ (defun get-types-of-node (elem tm-id &key (parent-xml-base nil)) "Returns a plist of all node's types of the form (:topicid <string> :psi <string> :ID <string>)." - (let ((xml-base (get-xml-base elem :old-base parent-xml-base))) - (remove-if - #'null - (append (unless (string= (get-type-of-node-name elem) - (concatenate 'string *rdf-ns* - "Description")) - (list - (list :topicid (get-type-of-node-name elem) - :psi (get-type-of-node-name elem) - :ID nil))) - (get-types-of-node-content elem tm-id xml-base))))) \ No newline at end of file + (remove-if + #'null + (append (unless (string= (get-type-of-node-name elem) + (concatenate 'string *rdf-ns* + "Description")) + (list + (list :topicid (get-type-of-node-name elem) + :psi (get-type-of-node-name elem) + :ID nil))) + (get-types-of-node-content elem tm-id parent-xml-base)))) \ No newline at end of file

1 0

[isidorus-cvs] r138 - trunk/src/xml/rdf
by Lukas Giessmann 08 Sep '09

08 Sep '09

Author: lgiessmann Date: Tue Sep 8 09:37:26 2009 New Revision: 138 Log: rdf-importer: fixed a bug when importing rdf-isidorus-names without nametypes. Modified: trunk/src/xml/rdf/map_to_tm.lisp Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 09:37:26 2009 @@ -277,8 +277,7 @@ "Maps the passed occurrence-topic to a TM occurrence." (declare (TopicC top name-top)) (declare (integer start-revision)) - (let ((err-pref "From map-isi-name(): ") - (ids (map-isi-identifiers name-top start-revision)) + (let ((ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type name-top start-revision *tm2rdf-nametype-property* @@ -290,8 +289,11 @@ (value-type-topic (get-item-by-psi *tm2rdf-value-property*)) (variant-topics (get-isi-variants name-top start-revision))) - (let ((types (get-players-by-role-type - type-assocs start-revision *rdf2tm-object*)) + (let ((types (let ((fn-types + (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*))) + (when fn-types + (first fn-types)))) (scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value @@ -305,14 +307,11 @@ (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct type-assocs) (map 'list #'d::delete-construct scope-assocs) - (when (/= 1 (length types)) - (error "~aexpect one type topic but found: ~a (~a)" - err-pref (length types) value)) (let ((name (make-construct 'NameC :start-revision start-revision :topic top :charvalue value - :instance-of (first types) + :instance-of types :item-identifiers ids :themes scopes))) (map 'list #'(lambda(variant-top)

1 0

[isidorus-cvs] r137 - trunk/src/unit_tests
by Lukas Giessmann 08 Sep '09

08 Sep '09

Author: lgiessmann Date: Tue Sep 8 06:54:19 2009 New Revision: 137 Log: rdf-importer: added some unit-tests Modified: trunk/src/unit_tests/full_mapping.rdf trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 06:54:19 2009 @@ -31,7 +31,7 @@ </rdf:Description> - <rdf:Description rdf:nodeID="id_285"> + <rdf:Description rdf:nodeID="id_283"> <isi:variant rdf:parseType="Resource"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> <isi:scope rdf:resource="http://simpsons/display"/> @@ -121,13 +121,13 @@ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> </rdf:Description> - <rdf:Description> + <rdf:Description rdf:nodeID="id_291"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/> <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-2</isi:itemIdentity> <isi:associationtype rdf:resource="http://simpsons/married"/> <isi:role> - <rdf:Description> + <rdf:Description rdf:nodeID="id_295"> <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/wife"/> @@ -135,7 +135,7 @@ </rdf:Description> </isi:role> <isi:role> - <rdf:Description> + <rdf:Description rdf:nodeID="id_292"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/husband"/> <isi:player rdf:resource="http://simpsons/homer"/> Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Tue Sep 8 06:54:19 2009 @@ -66,7 +66,10 @@ :test-poems-rdf-topics :test-empty-collection :test-collection - :test-xml-base)) + :test-xml-base + :test-full-mapping-marge + :test-full-mapping-homer + :test-full-mapping-association)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -79,6 +82,14 @@ (in-suite rdf-importer-test) +(defun empty-p (top) + (declare (TopicC top)) + (and (not (d:item-identifiers top)) + (not (d:locators top)) + (not (d:names top)) + (not (d:occurrences top)))) + + (test test-get-literals-of-node "Tests the helper function get-literals-of-node." (let ((doc-1 @@ -3060,6 +3071,306 @@ "/test") "http://base-3/test"))))))) + +(test test-full-mapping-marge + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((firstName (get-item-by-id "http://simpsons/firstName")) + (lastName (get-item-by-id "http://simpsons/lastName")) + (display (get-item-by-id "http://simpsons/display")) + (profession (get-item-by-id "http://simpsons/profession")) + (married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (en (get-item-by-id "http://simpsons/en")) + (type (get-item-by-psi *type-psi*)) + (instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (isi-object (get-item-by-psi *rdf2tm-object*)) + (isi-subject (get-item-by-psi *rdf2tm-subject*)) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true firstName) + (is-true (empty-p firstName)) + (is-true lastName) + (is-true (empty-p lastName)) + (is-true display) + (is-true (empty-p display)) + (is-true profession) + (is-true (empty-p profession)) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true en) + (is-true (empty-p en)) + (is-true type) + (is-true (empty-p type)) + (is-true instance) + (is-true (empty-p instance)) + (is-true type-instance) + (is-true (empty-p type-instance)) + (is-true isi-object) + (is-true (empty-p isi-object)) + (is-true isi-subject) + (is-true (empty-p isi-subject)) + (is-true role-husband) + (is-true role-wife) + (is-true homer) + (is (= (length (d:psis marge)) 2)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/marjorie")) + (d:psis marge))) + (is (= (length (d:names marge)) 2)) + (let ((marge-fn (find-if #'(lambda(x) + (eql (instance-of x) firstName)) + (d:names marge))) + (marge-ln (find-if #'(lambda(x) + (eql (instance-of x) lastName)) + (d:names marge))) + (marge-occ (find-if #'(lambda(x) + (eql (instance-of x) profession)) + (d:occurrences marge)))) + (is-true marge-fn) + (is-true marge-ln) + (is (string= (d:charvalue marge-fn) "Marjorie")) + (is (string= (d:charvalue marge-ln) "Simpson")) + (is (= (length (d:variants marge-fn)) 1)) + (is (= (length (d:themes (first (d:variants marge-fn)))) 1)) + (is (eql (first (d:themes (first (d:variants marge-fn)))) display)) + (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge")) + (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*)) + (is-true marge-occ) + (is (string= (d:charvalue marge-occ) "Housewife")) + (is (string= (d:datatype marge-occ) *xml-string*)) + (is (= (length (d:themes marge-occ)) 0)) + (is (= (length (d:psis marge)) 2)))))) + + +(test test-full-mapping-homer + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((firstName (get-item-by-id "http://simpsons/firstName")) + (lastName (get-item-by-id "http://simpsons/lastName")) + (display (get-item-by-id "http://simpsons/display")) + (profession (get-item-by-id "http://simpsons/profession")) + (married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (en (get-item-by-id "http://simpsons/en")) + (type (get-item-by-psi *type-psi*)) + (instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (isi-object (get-item-by-psi *rdf2tm-object*)) + (isi-subject (get-item-by-psi *rdf2tm-subject*)) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true firstName) + (is-true (empty-p firstName)) + (is-true lastName) + (is-true (empty-p lastName)) + (is-true display) + (is-true (empty-p display)) + (is-true profession) + (is-true (empty-p profession)) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true en) + (is-true (empty-p en)) + (is-true type) + (is-true (empty-p type)) + (is-true instance) + (is-true (empty-p instance)) + (is-true type-instance) + (is-true (empty-p type-instance)) + (is-true isi-object) + (is-true (empty-p isi-object)) + (is-true isi-subject) + (is-true (empty-p isi-subject)) + (is-true role-husband) + (is-true role-wife) + (is-true marge) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/homer_simpson")) + (d:psis homer))) + (is (= (length (d:locators homer)) 1)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://some.where/resource")) + (d:locators homer))) + (is (= (length (d:item-identifiers homer)) 1)) + (is-true (find-if #'(lambda(x) + (string= (d:uri x) "http://simpsons/ii/homer")) + (d:item-identifiers homer))) + (is (= (length (d:names homer)) 2)) + (let ((homer-fn (find-if #'(lambda(x) + (eql (instance-of x) firstName)) + (d:names homer))) + (homer-ln (find-if #'(lambda(x) + (eql (instance-of x) lastName)) + (d:names homer))) + (homer-occ (find-if #'(lambda(x) + (eql (instance-of x) profession)) + (d:occurrences homer)))) + (is-true homer-fn) + (is-true homer-ln) + (is (string= (d:charvalue homer-fn) "Homer J.")) + (is (string= (d:charvalue homer-ln) "Simpson")) + (is (= (length (d:variants homer-fn)) 1)) + (is (= (length (d:themes (first (d:variants homer-fn)))) 1)) + (is (eql (first (d:themes (first (d:variants homer-fn)))) display)) + (is (string= (d:charvalue (first (d:variants homer-fn))) "Homer")) + (is (string= (d:datatype (first (d:variants homer-fn))) *xml-string*)) + (is-true homer-occ) + (is (string= (d:charvalue homer-occ) "Safety Inspector")) + (is (string= (d:datatype homer-occ) *xml-string*)) + (is (= (length (d:themes homer-occ)) 1)) + (is (eql (first (d:themes homer-occ)) en)))))) + + +(test test-full-mapping-association + "Tests the entire importer module." + (let ((dir "data_base") + (rdf-file unittests-constants:*full_mapping.rdf*) + (tm-id "http://full-mapping/") + (document-id "http://full_mapping.rdf")) + (when elephant:*store-controller* + (elephant:close-store)) + (fixtures::clean-out-db dir) + (rdf-importer:rdf-importer rdf-file dir + :tm-id tm-id + :document-id document-id) + (elephant:open-store (xml-importer:get-store-spec dir)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) + (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) + (is (= (length (elephant:get-instances-by-class 'd:RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2)) + (setf d:*current-xtm* document-id) + (let ((married (get-item-by-id "http://simpsons/married")) + (husband (get-item-by-id "http://simpsons/husband")) + (wife (get-item-by-id "http://simpsons/wife")) + (marge (get-item-by-id "http://simpsons/marge")) + (homer (get-item-by-id "http://simpsons/homer")) + (assoc (first (elephant:get-instances-by-class 'd:AssociationC))) + (role-husband + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-husband/ii")))) + (elephant:get-instances-by-class 'd:RoleC))) + (role-wife + (find-if #'(lambda(x) + (let ((iis (d:item-identifiers x))) + (when (= (length iis) 1) + (string= (d:uri (first iis)) + "http://simpsons/role-wife/ii")))) + (elephant:get-instances-by-class 'd:RoleC)))) + (is-true married) + (is-true (empty-p married)) + (is-true husband) + (is-true (empty-p husband)) + (is-true wife) + (is-true (empty-p wife)) + (is-true role-husband) + (is-true role-wife) + (is-true marge) + (is-true homer) + (is (= (length (intersection (list role-husband role-wife) + (d:roles assoc))) + 2)) + (is (eql (d:instance-of assoc) married)) + (is (= (length (d:item-identifiers assoc)) 2)) + (is (= (length + (intersection + (list + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri "http://simpsons/married/ii-2")) + (d:item-identifiers assoc))) + 2)) + (is (eql (d:instance-of role-husband) husband)) + (is (eql (d:instance-of role-wife) wife)) + (is (eql (d:player role-husband) homer)) + (is (eql (d:player role-wife) marge)) + (is (= (length (d:item-identifiers role-husband)) 1)) + (is (= (length (d:item-identifiers role-wife)) 1)) + (is (string= (d:uri (first (d:item-identifiers role-husband))) + "http://simpsons/role-husband/ii")) + (is (string= (d:uri (first (d:item-identifiers role-wife))) + "http://simpsons/role-wife/ii"))))) + + (defun run-rdf-importer-tests() "Runs all defined tests." (when elephant:*store-controller* @@ -3082,4 +3393,7 @@ (it.bese.fiveam:run! 'test-poems-rdf-topics) (it.bese.fiveam:run! 'test-empty-collection) (it.bese.fiveam:run! 'test-collection) - (it.bese.fiveam:run! 'test-xml-base)) \ No newline at end of file + (it.bese.fiveam:run! 'test-xml-base) + (it.bese.fiveam:run! 'test-full-mapping-marge) + (it.bese.fiveam:run! 'test-full-mapping-homer) + (it.bese.fiveam:run! 'test-full-mapping-association)) \ No newline at end of file Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Tue Sep 8 06:54:19 2009 @@ -30,7 +30,8 @@ :*atom_test.xtm* :*atom-conf.lisp* :*poems_light.rdf* - :*poems_light.xtm*)) + :*poems_light.xtm* + :*full_mapping.rdf*)) (in-package :unittests-constants) @@ -99,3 +100,7 @@ (defparameter *poems_light.xtm* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light.xtm"))) + +(defparameter *full_mapping.rdf* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "full_mapping.rdf"))) \ No newline at end of file

1 0

[isidorus-cvs] r136 - in trunk/src: . unit_tests xml/rdf
by Lukas Giessmann 08 Sep '09

08 Sep '09

Author: lgiessmann Date: Tue Sep 8 04:51:36 2009 New Revision: 136 Log: rdf-exporter: fixed a bug with missing name-types; rdf-importer: fixed a bug with merging/versioning of blank_nodes --> they get an item-identifier concatenated of a predefined prefix and their nodeID or a UUID Modified: trunk/src/constants.lisp trunk/src/unit_tests/full_mapping.rdf trunk/src/xml/rdf/exporter.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Tue Sep 8 04:51:36 2009 @@ -61,7 +61,8 @@ :*tm2rdf-occurrencetype-property* :*tm2rdf-roletype-property* :*tm2rdf-associationtype-property* - :*tm2rdf-player-property*)) + :*tm2rdf-player-property* + :*rdf2tm-blank-node-prefix*)) (in-package :constants) @@ -123,6 +124,8 @@ (defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/")) +(defparameter *rdf2tm-blank-node-prefix* (concatenate 'string *rdf2tm-ns* "blank_node/")) + (defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/") (defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "types/Topic")) Modified: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- trunk/src/unit_tests/full_mapping.rdf (original) +++ trunk/src/unit_tests/full_mapping.rdf Tue Sep 8 04:51:36 2009 @@ -64,7 +64,7 @@ </isi:variant> </rdf:Description> </isi:name> -   + <isi:name rdf:resource="id_2345"/>  <isi:name> <rdf:Description rdf:nodeID="id_277"> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> @@ -102,7 +102,7 @@ <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> <isi:role> <rdf:Description rdf:nodeID="id_292"> - <isi:itemIdentity rdf:datatype="">http://simpsons/role-husband/ii</isi:itemIdentity> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-husband/ii</isi:itemIdentity> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/husband"/> <isi:player rdf:resource="http://simpsons/homer"/> @@ -117,15 +117,29 @@ </isi:role> </rdf:Description> + <rdf:Description rdf:nodeID="id_295"> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> + </rdf:Description> + <rdf:Description> - <isi:itemIdentity rdf:datatype="">http://simpsons/maried/ii-2</isi:itemIdentity> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-2</isi:itemIdentity> + <isi:associationtype rdf:resource="http://simpsons/married"/> <isi:role> - <rdf:Description rdf:nodeID="id_295"> - <isi:itemIdentity rdf:datatype="">http://simpsons/role-wife/ii</isi:itemIdentity> + <rdf:Description> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/role-wife/ii</isi:itemIdentity> <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> <isi:roletype rdf:resource="http://simpsons/wife"/> <isi:player rdf:resource="http://simpsons/marge"/> </rdf:Description> </isi:role> + <isi:role> + <rdf:Description> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/husband"/> + <isi:player rdf:resource="http://simpsons/homer"/> + </rdf:Description> + </isi:role> </rdf:Description> -</rdf:RDF> \ No newline at end of file +</rdf:RDF> Modified: trunk/src/xml/rdf/exporter.lisp ============================================================================== --- trunk/src/xml/rdf/exporter.lisp (original) +++ trunk/src/xml/rdf/exporter.lisp Tue Sep 8 04:51:36 2009 @@ -39,7 +39,7 @@ to be exported, the same mechanism as in xtm-exporter") -(defvar *ns-map* nil) ;; ((:prefix <string> :uri <string>)) +(defvar *ns-map* nil "((:prefix <string> :uri <string>))") (defun rdf-li-or-uri (uri) @@ -297,8 +297,9 @@ (cxml:attribute "rdf:nodeID" (make-object-id construct)) (make-isi-type *tm2rdf-name-type-uri*) (map 'list #'to-rdf-elem (item-identifiers construct)) - (cxml:with-element "isi:nametype" - (make-topic-reference (instance-of construct))) + (when (slot-boundp construct 'instance-of) + (cxml:with-element "isi:nametype" + (make-topic-reference (instance-of construct)))) (scopes-to-rdf-elems construct) (cxml:with-element "isi:value" (cxml:attribute "rdf:datatype" *xml-string*) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Tue Sep 8 04:51:36 2009 @@ -411,28 +411,25 @@ If about or ID is set there will also be created a new PSI." (declare (TopicMapC tm)) (let ((topic-id (or about ID nodeID UUID)) - (psi-uri (or about ID))) + (psi-uri (or about ID)) + (ii-uri (unless (or about ID) + (concatenate 'string *rdf2tm-blank-node-prefix* + (or nodeID UUID))))) (let ((top ;seems like there is a bug in d:get-item-by-id: ;this functions returns an emtpy topic although there is no one - ;with a corresponding topic id and/or version and/or xtm-id + ;with a corresponding topic id and/or version. + ;Thus the version is temporary checked manually. (let ((inner-top (get-item-by-id topic-id :xtm-id document-id :revision start-revision))) - ;;(when inner-top - ;; (let ((versions (d::versions inner-top))) - ;; (unless (find-if #'(lambda(version) - ;; (= start-revision - ;; (d::start-revision version))) - ;; versions) - ;; (d::add-to-version-history inner-top - ;; :start-revision start-revision) - ;; (add-to-topicmap tm inner-top))))))) - (when (and inner-top - (find-if #'(lambda(x) - (= (d::start-revision x) start-revision)) - (d::versions inner-top))) - inner-top)))) + (when inner-top + (let ((versions (d::versions inner-top))) + (when (find-if #'(lambda(version) + (= start-revision + (d::start-revision version))) + versions) + inner-top)))))) (if top top (elephant:ensure-transaction (:txn-nosync t) @@ -440,7 +437,12 @@ (list (make-instance 'PersistentIdC :uri psi-uri - :start-revision start-revision))))) + :start-revision start-revision)))) + (iis (when ii-uri + (list + (make-instance 'ItemIdentifierC + :uri ii-uri + :start-revision start-revision))))) (handler-case (let ((top (add-to-topicmap tm @@ -448,6 +450,7 @@ 'TopicC :topicid topic-id :psis psis + :item-identifiers iis :xtm-id document-id :start-revision start-revision)))) (format t "t") @@ -463,12 +466,12 @@ (when lang (let ((psi-and-topic-id (concatenate-uri *rdf2tm-scope-prefix* lang))) - (let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id - :revision start-revision))) - (if top - top - (make-topic-stub psi-and-topic-id nil nil nil start-revision - tm :document-id document-id)))))) + ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id +; :revision start-revision))) +; (if top +; top + (make-topic-stub psi-and-topic-id nil nil nil start-revision + tm :document-id document-id)))) (defun make-association (top association tm start-revision Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Tue Sep 8 04:51:36 2009 @@ -71,13 +71,15 @@ (type-instance (get-item-by-psi *type-instance-psi*)) (type (get-item-by-psi *type-psi*))) (declare (TopicC instance-topic type-topic)) - (let ((assocs (map 'list - #'(lambda(role) - (when (and (eql (instance-of role) instance) - (eql (instance-of (parent role)) - type-instance)) - (parent role))) - (player-in-roles instance-topic)))) + (let ((assocs (remove-if + #'null + (map 'list + #'(lambda(role) + (when (and (eql (instance-of role) instance) + (eql (instance-of (parent role)) + type-instance)) + (parent role))) + (player-in-roles instance-topic))))) (map 'list #'(lambda(assoc) (when (find-if #'(lambda(role) (and (eql (instance-of role) type) @@ -86,6 +88,13 @@ (d::delete-construct assoc))) assocs) nil)))) + + +(defun delete-related-associations (top) + "Deletes all associaitons related to the passed topic." + (dolist (assoc-role (player-in-roles top)) + (d::delete-construct (parent assoc-role))) + top) (defun get-isi-roles(assoc-top start-revision) @@ -109,8 +118,6 @@ (declare (TopicC role-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-role(): ") - (role-type-topic (get-item-by-psi *tm2rdf-role-type-uri* - :revision start-revision)) (ids (map-isi-identifiers role-top start-revision)) (type-assocs (get-associations-by-type @@ -133,7 +140,7 @@ (when (= 0 (length role-players)) (error "~aexpect one player but found: ~a" err-pref (length role-players))) - (delete-instance-of-association role-top role-type-topic) + (delete-related-associations role-top) (d::delete-construct role-top) (list :instance-of (first types) :player (first role-players) @@ -175,6 +182,7 @@ (when (= 0 (length assoc-roles)) (error "~aexpect at least one role but found: ~a" err-pref (length assoc-roles))) + (delete-related-associations assoc-top) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) (add-to-topicmap @@ -234,8 +242,6 @@ (declare (NameC name)) (declare (integer start-revision)) (let ((ids (map-isi-identifiers variant-top start-revision)) - (variant-type-topic (get-item-by-psi *tm2rdf-variant-type-uri* - :revision start-revision)) (scope-assocs (get-associations-by-type variant-top start-revision *tm2rdf-scope-property* @@ -256,7 +262,7 @@ :datatype *xml-string*))))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) - (delete-instance-of-association variant-top variant-type-topic) + (delete-related-associations variant-top) (d::delete-construct variant-top) (make-construct 'VariantC :start-revision start-revision @@ -272,8 +278,6 @@ (declare (TopicC top name-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-name(): ") - (name-type-topic (get-item-by-psi *tm2rdf-name-type-uri* - :revision start-revision)) (ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type @@ -314,7 +318,7 @@ (map 'list #'(lambda(variant-top) (map-isi-variant name variant-top start-revision)) variant-topics) - (delete-instance-of-association name-top name-type-topic) + (delete-related-associations name-top) (d::delete-construct name-top) name))))) @@ -339,8 +343,6 @@ (declare (integer start-revision)) (let ((err-pref "From map-isi-occurrence(): ") (ids (map-isi-identifiers occ-top start-revision)) - (occurrence-type-topic (get-item-by-psi *tm2rdf-occurrence-type-uri* - :revision start-revision)) (type-assocs (get-associations-by-type occ-top start-revision *tm2rdf-occurrencetype-property* @@ -371,7 +373,7 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) - (delete-instance-of-association occ-top occurrence-type-topic) + (delete-related-associations occ-top) (d::delete-construct occ-top) (make-construct 'OccurrenceC :start-revision start-revision Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Tue Sep 8 04:51:36 2009 @@ -53,7 +53,8 @@ *tm2rdf-occurrencetype-property* *tm2rdf-roletype-property* *tm2rdf-player-property* - *tm2rdf-associationtype-property*) + *tm2rdf-associationtype-property* + *rdf2tm-blank-node-prefix*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*) @@ -509,4 +510,4 @@ (list :topicid (get-type-of-node-name elem) :psi (get-type-of-node-name elem) :ID nil))) - (get-types-of-node-content elem tm-id xml-base))))) + (get-types-of-node-content elem tm-id xml-base))))) \ No newline at end of file

1 0

[isidorus-cvs] r135 - in trunk/src: . unit_tests xml/rdf
by Lukas Giessmann 07 Sep '09

07 Sep '09

Author: lgiessmann Date: Mon Sep 7 10:43:54 2009 New Revision: 135 Log: rdf-importer: added an RDF test file with exported and mapped TM constructs. Added: trunk/src/unit_tests/full_mapping.rdf Modified: trunk/src/isidorus.asd trunk/src/xml/rdf/map_to_tm.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Sep 7 10:43:54 2009 @@ -110,6 +110,7 @@ (:static-file "poems.rdf") (:static-file "poems_light.rdf") (:static-file "poems_light.xtm") + (:static-file "full_mapping.rdf") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Added: trunk/src/unit_tests/full_mapping.rdf ============================================================================== --- (empty file) +++ trunk/src/unit_tests/full_mapping.rdf Mon Sep 7 10:43:54 2009 @@ -0,0 +1,131 @@ +<?xml version="1.0" encoding="UTF-8"?> +<rdf:RDF xmlns:isi="http://isidorus/tm2rdf_mapping/" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:rdfs="http://www.w3.org/2000/01/rdf-schema#" + xmlns:xml="http://www.w3.org/XML/1998/namespace"> +  + <rdf:Description rdf:about="http://simpsons/marge"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Topic"/> + <isi:name> + <rdf:Description rdf:nodeID="id_283"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/firstName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Marjorie</isi:value> + </rdf:Description> + </isi:name> + <isi:name> + <rdf:Description rdf:nodeID="id_285"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/lastName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Simpson</isi:value> + </rdf:Description> + </isi:name> + <ns5:profession xmlns:ns5="http://simpsons/" rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Housewife</ns5:profession> + <isi:occurrence rdf:nodeID="id_1234"/>  + </rdf:Description> + + <rdf:Description rdf:nodeID="id_1234"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Occurrence"/> + <isi:occurrencetype rdf:resource="http://simpsons/profession"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Housewife</isi:value> + </rdf:Description> + + + <rdf:Description rdf:nodeID="id_285"> + <isi:variant rdf:parseType="Resource"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> + <isi:scope rdf:resource="http://simpsons/display"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Marge</isi:value> + </isi:variant> + </rdf:Description> + + + <rdf:Description rdf:about="http://simpsons/marge"> + <isi:subjectIdentifier rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/marjorie</isi:subjectIdentifier> + </rdf:Description> + +  + <rdf:Description rdf:about="http://simpsons/homer"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Topic"/> + <isi:subjectIdentifier rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/homer_simpson</isi:subjectIdentifier> + <isi:subjectLocator rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://some.where/resource</isi:subjectLocator> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/ii/homer</isi:itemIdentity> + <isi:name> + <rdf:Description rdf:nodeID="id_266"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/firstName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer J.</isi:value> + <isi:variant> + <rdf:Description rdf:nodeID="id_272"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> + <isi:scope rdf:resource="http://simpsons/display"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer</isi:value> + </rdf:Description> + </isi:variant> + </rdf:Description> + </isi:name> +   + <isi:name> + <rdf:Description rdf:nodeID="id_277"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/lastName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Simpson</isi:value> + </rdf:Description> + </isi:name> + <isi:occurrence> + <rdf:Description rdf:nodeID="id_279"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Occurrence"/> + <isi:occurrencetype rdf:resource="http://simpsons/profession"/> + <isi:scope rdf:resource="http://simpsons/en"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Safety Inspector</isi:value> + </rdf:Description> + </isi:occurrence> + </rdf:Description> + + <rdf:Description rdf:about="id_2345"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Name"/> + <isi:nametype rdf:resource="http://simpsons/firstName"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer J.</isi:value> + <isi:variant> + <rdf:Description rdf:nodeID="id_272"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Variant"/> + <isi:scope rdf:resource="http://simpsons/display"/> + <isi:value rdf:datatype="http://www.w3.org/2001/XMLSchema#string">Homer</isi:value> + </rdf:Description> + </isi:variant> + </rdf:Description> + +  + <rdf:Description rdf:nodeID="id_291"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Association"/> + <isi:associationtype rdf:resource="http://simpsons/married"/> + <isi:itemIdentity rdf:datatype="http://www.w3.org/2001/XMLSchema#anyURI">http://simpsons/married/ii-1</isi:itemIdentity> + <isi:role> + <rdf:Description rdf:nodeID="id_292"> + <isi:itemIdentity rdf:datatype="">http://simpsons/role-husband/ii</isi:itemIdentity> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/husband"/> + <isi:player rdf:resource="http://simpsons/homer"/> + </rdf:Description> + </isi:role> + <isi:role> + <rdf:Description rdf:nodeID="id_295"> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/wife"/> + <isi:player rdf:resource="http://simpsons/marge"/> + </rdf:Description> + </isi:role> + </rdf:Description> + + <rdf:Description> + <isi:itemIdentity rdf:datatype="">http://simpsons/maried/ii-2</isi:itemIdentity> + <isi:role> + <rdf:Description rdf:nodeID="id_295"> + <isi:itemIdentity rdf:datatype="">http://simpsons/role-wife/ii</isi:itemIdentity> + <rdf:type rdf:resource="http://isidorus/tm2rdf_mapping/types/Role"/> + <isi:roletype rdf:resource="http://simpsons/wife"/> + <isi:player rdf:resource="http://simpsons/marge"/> + </rdf:Description> + </isi:role> + </rdf:Description> +</rdf:RDF> \ No newline at end of file Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 10:43:54 2009 @@ -302,8 +302,8 @@ (map 'list #'d::delete-construct type-assocs) (map 'list #'d::delete-construct scope-assocs) (when (/= 1 (length types)) - (error "~aexpect one type topic but found: ~a" - err-pref (length types))) + (error "~aexpect one type topic but found: ~a (~a)" + err-pref (length types) value)) (let ((name (make-construct 'NameC :start-revision start-revision :topic top

1 0

[isidorus-cvs] r134 - in trunk/src: model xml/rdf
by Lukas Giessmann 07 Sep '09

07 Sep '09

Author: lgiessmann Date: Mon Sep 7 07:21:34 2009 New Revision: 134 Log: rdf-importer: all rdf-isidorus-types are mapped to the corresponding TM-constructs; fixed a bug in datamodel with deleteing associations and topics from topicMaps Modified: trunk/src/model/datamodel.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Mon Sep 7 07:21:34 2009 @@ -272,6 +272,7 @@ (dolist (versioninfo (versions construct)) (delete-construct versioninfo))) + (defgeneric add-to-version-history (construct &key start-revision end-revision) (:documentation "Add version history to a topic map construct")) @@ -990,7 +991,9 @@ (used-as-type construct))) (delete-construct dependent)) (dolist (theme (used-as-theme construct)) - (elephant:remove-association construct 'used-as-theme theme))) + (elephant:remove-association construct 'used-as-theme theme)) + (dolist (tm (in-topicmaps construct)) + (elephant:remove-association construct 'in-topicmaps tm))) (defun get-all-constructs-by-uri (uri) (delete @@ -1422,7 +1425,9 @@ (defmethod delete-construct :before ((construct AssociationC)) (dolist (role (roles construct)) - (delete-construct role))) + (delete-construct role)) + (dolist (tm (in-topicmaps construct)) + (elephant:remove-association construct 'in-topicmaps tm))) (defmethod find-all-equivalent ((construct AssociationC)) (let Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 07:21:34 2009 @@ -19,32 +19,179 @@ (map 'list #'(lambda(top) (map-isi-topic top start-revision)) topics-to-map)) - (mapped-associations associations-to-map)) - - (append mapped-topics mapped-associations) - ;check-for-duplicate-identifiers - ;delete-construct: - ; *item-identifier-property - ; *subject-identifier-property - ; *subject-locator-proeprty* - ; *topic-type - ; *occurrence-type - ; *occurrence-property - ; *name-type - ; *name-property - ; *variant-type - ; *variant-property - ; *occurrence-type-property - ; *value-property - ; *scope-property - ; *nametype-property - ))) + (mapped-associations + (map 'list #'(lambda(top) + (map-isi-association top start-revision tm-id + :document-id document-id)) + associations-to-map))) + (let ((constructs + (append mapped-topics mapped-associations))) + (clear-store start-revision) + (map 'list #'d::check-for-duplicate-identifiers constructs) + constructs)))) + + +(defun clear-store(start-revision) + "Deletes all topics that are neede for RDF2TM mapping and are not + referenced in an associaiton, as type or scope." + (let ((psi-uris + (list *tm2rdf-topic-type-uri* *tm2rdf-name-type-uri* + *tm2rdf-variant-type-uri* *tm2rdf-occurrence-type-uri* + *tm2rdf-association-type-uri* *tm2rdf-role-type-uri* + *tm2rdf-itemIdentity-property* *tm2rdf-subjectLocator-property* + *tm2rdf-subjectIdentifier-property* *tm2rdf-role-property* + *tm2rdf-subjectIdentifier-property* *tm2rdf-player-property* + *tm2rdf-nametype-property* *tm2rdf-value-property* + *tm2rdf-occurrence-property* *tm2rdf-roletype-property* + *tm2rdf-variant-property* *tm2rdf-occurrencetype-property* + *tm2rdf-name-property* *tm2rdf-associationtype-property* + *tm2rdf-scope-property*))) + (dolist (uri psi-uris) + (delete-topic-if-not-referenced uri start-revision)))) + + +(defun delete-topic-if-not-referenced(type-psi start-revision) + "Deletes a topic when it is not referenced." + (declare (string type-psi)) + (declare (integer start-revision)) + (let ((type-topic (get-item-by-psi type-psi + :revision start-revision))) + (when type-topic + (when (and (not (player-in-roles type-topic)) + (not (used-as-type type-topic)) + (not (used-as-theme type-topic))) + (d::delete-construct type-topic))))) + + +(defun delete-instance-of-association(instance-topic type-topic) + "Deletes a type-instance associaiton that corresponds woith the passed + parameters." + (when (and instance-topic type-topic) + (let ((instance (get-item-by-psi *instance-psi*)) + (type-instance (get-item-by-psi *type-instance-psi*)) + (type (get-item-by-psi *type-psi*))) + (declare (TopicC instance-topic type-topic)) + (let ((assocs (map 'list + #'(lambda(role) + (when (and (eql (instance-of role) instance) + (eql (instance-of (parent role)) + type-instance)) + (parent role))) + (player-in-roles instance-topic)))) + (map 'list #'(lambda(assoc) + (when (find-if #'(lambda(role) + (and (eql (instance-of role) type) + (eql (player role) type-topic))) + (roles assoc)) + (d::delete-construct assoc))) + assocs) + nil)))) + + +(defun get-isi-roles(assoc-top start-revision) + "Returns all topics representing association-roles." + (declare (TopicC assoc-top)) + (declare (integer start-revision)) + (let ((role-assocs + (get-associations-by-type assoc-top start-revision + *tm2rdf-role-property* + *rdf2tm-subject*))) + (let ((players + (get-players-by-role-type role-assocs start-revision + *rdf2tm-object*))) + (map 'list #'d::delete-construct role-assocs) + players))) + + +(defun map-isi-role(role-top start-revision) + "Maps a passed topic with all its isidorus:types to a + property list representing an association-role." + (declare (TopicC role-top)) + (declare (integer start-revision)) + (let ((err-pref "From map-isi-role(): ") + (role-type-topic (get-item-by-psi *tm2rdf-role-type-uri* + :revision start-revision)) + (ids (map-isi-identifiers role-top start-revision)) + (type-assocs + (get-associations-by-type + role-top start-revision *tm2rdf-roletype-property* + *rdf2tm-subject*)) + (player-assocs + (get-associations-by-type + role-top start-revision *tm2rdf-player-property* + *rdf2tm-subject*))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (role-players (get-players-by-role-type + player-assocs start-revision *rdf2tm-object*))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct player-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (when (= 0 (length role-players)) + (error "~aexpect one player but found: ~a" + err-pref (length role-players))) + (delete-instance-of-association role-top role-type-topic) + (d::delete-construct role-top) + (list :instance-of (first types) + :player (first role-players) + :item-identifiers ids))))) + + +(defun map-isi-association(assoc-top start-revision tm-id + &key (document-id *document-id*)) + "Maps a passed topic with all its isidorus:types to a TM association." + (declare (TopicC assoc-top)) + (declare (integer start-revision)) + (format t "A") + (let ((err-pref "From map-isi-association(): ") + (ids (map-isi-identifiers assoc-top start-revision)) + (type-assocs + (get-associations-by-type + assoc-top start-revision *tm2rdf-associationtype-property* + *rdf2tm-subject*)) + (scope-assocs + (get-associations-by-type + assoc-top start-revision *tm2rdf-scope-property* + *rdf2tm-subject*)) + (role-tops (get-isi-roles assoc-top start-revision))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (assoc-roles + (remove-if #'null (map 'list + #'(lambda(role-top) + (map-isi-role role-top start-revision)) + role-tops)))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct scope-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (when (= 0 (length assoc-roles)) + (error "~aexpect at least one role but found: ~a" + err-pref (length assoc-roles))) + (d::delete-construct assoc-top) + (with-tm (start-revision document-id tm-id) + (add-to-topicmap + xml-importer::tm + (make-construct 'AssociationC + :start-revision start-revision + :item-identifiers ids + :instance-of (first types) + :themes scopes + :roles assoc-roles))))))) (defun map-isi-topic(top start-revision) - "maps a passed topic with all its isidorus:types to a TM topic." + "Maps a passed topic with all its isidorus:types to a TM topic." (declare (integer start-revision)) (declare(TopicC top)) + (format t "T") (let ((new-psis (map-isi-identifiers top start-revision :id-type-uri *tm2rdf-subjectidentifier-property*)) @@ -87,13 +234,14 @@ (declare (NameC name)) (declare (integer start-revision)) (let ((ids (map-isi-identifiers variant-top start-revision)) + (variant-type-topic (get-item-by-psi *tm2rdf-variant-type-uri* + :revision start-revision)) (scope-assocs (get-associations-by-type - variant-top start-revision - (concatenate 'string *tm2rdf-ns* "scope") + variant-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (get-item-by-psi *tm2rdf-value-property*))) (let ((scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value-and-datatype @@ -108,6 +256,7 @@ :datatype *xml-string*))))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) + (delete-instance-of-association variant-top variant-type-topic) (d::delete-construct variant-top) (make-construct 'VariantC :start-revision start-revision @@ -123,19 +272,19 @@ (declare (TopicC top name-top)) (declare (integer start-revision)) (let ((err-pref "From map-isi-name(): ") + (name-type-topic (get-item-by-psi *tm2rdf-name-type-uri* + :revision start-revision)) (ids (map-isi-identifiers name-top start-revision)) (type-assocs (get-associations-by-type - name-top start-revision - (concatenate 'string *tm2rdf-ns* "nametype") + name-top start-revision *tm2rdf-nametype-property* *rdf2tm-subject*)) (scope-assocs (get-associations-by-type - name-top start-revision - (concatenate 'string *tm2rdf-ns* "scope") + name-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value"))) + (get-item-by-psi *tm2rdf-value-property*)) (variant-topics (get-isi-variants name-top start-revision))) (let ((types (get-players-by-role-type type-assocs start-revision *rdf2tm-object*)) @@ -165,6 +314,7 @@ (map 'list #'(lambda(variant-top) (map-isi-variant name variant-top start-revision)) variant-topics) + (delete-instance-of-association name-top name-type-topic) (d::delete-construct name-top) name))))) @@ -189,18 +339,18 @@ (declare (integer start-revision)) (let ((err-pref "From map-isi-occurrence(): ") (ids (map-isi-identifiers occ-top start-revision)) + (occurrence-type-topic (get-item-by-psi *tm2rdf-occurrence-type-uri* + :revision start-revision)) (type-assocs (get-associations-by-type - occ-top start-revision - (concatenate 'string *tm2rdf-ns* "occurrencetype") + occ-top start-revision *tm2rdf-occurrencetype-property* *rdf2tm-subject*)) (scope-assocs (get-associations-by-type - occ-top start-revision - (concatenate 'string *tm2rdf-ns* "scope") + occ-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (get-item-by-psi *tm2rdf-value-property*))) (let ((types (get-players-by-role-type type-assocs start-revision *rdf2tm-object*)) (scopes (get-players-by-role-type @@ -221,6 +371,7 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) + (delete-instance-of-association occ-top occurrence-type-topic) (d::delete-construct occ-top) (make-construct 'OccurrenceC :start-revision start-revision @@ -316,7 +467,6 @@ (player role)))) associations)))) players))) - (defun get-occurrences-by-type (top start-revision @@ -378,16 +528,24 @@ (declare (ReifiableConstructC construct)) (dolist (id identifiers) (declare (ItemIdentifierC id)) - (setf (identified-construct id) construct)) + (if (find-if #'(lambda(ii) + (string= (uri ii) (uri id))) + (item-identifiers construct)) + (d::delete-construct id) + (setf (identified-construct id) construct))) construct) (defun bound-subject-identifiers (top identifiers) - "Bounds the passed psis to the passed topic." + "Bounds the passed psis to the passed topic." (declare (TopicC top)) (dolist (id identifiers) (declare (PersistentIdC id)) - (setf (identified-construct id) top)) + (if (find-if #'(lambda(psi) + (string= (uri psi) (uri id))) + (psis top)) + (d::delete-construct id) + (setf (identified-construct id) top))) top) @@ -396,6 +554,9 @@ (declare (TopicC top)) (dolist (id locators) (declare (SubjectLocatorC id)) - (setf (identified-construct id) top)) + (if (find-if #'(lambda(locator) + (string= (uri locator) (uri id))) + (locators top)) + (d::delete-construct id) + (setf (identified-construct id) top))) top) - Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Sep 7 07:21:34 2009 @@ -46,7 +46,14 @@ *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* *tm2rdf-subjectLocator-property* - *tm2rdf-ns*) + *tm2rdf-ns* + *tm2rdf-value-property* + *tm2rdf-scope-property* + *tm2rdf-nametype-property* + *tm2rdf-occurrencetype-property* + *tm2rdf-roletype-property* + *tm2rdf-player-property* + *tm2rdf-associationtype-property*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*)

1 0

[isidorus-cvs] r133 - trunk/src/xml/rdf
by Lukas Giessmann 07 Sep '09

07 Sep '09

Author: lgiessmann Date: Mon Sep 7 04:44:19 2009 New Revision: 133 Log: rdf-importer: mapping isidorus:topics to full TM constructs is implemented by manipulating imported constructs from rdf in the db Modified: trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/map_to_tm.lisp trunk/src/xml/rdf/rdf_tools.lisp Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Sep 7 04:44:19 2009 @@ -42,6 +42,7 @@ (truename rdf-xml-path) (cxml-dom:make-dom-builder))))) (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) + (map-to-tm tm-id start-revision :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))) Modified: trunk/src/xml/rdf/map_to_tm.lisp ============================================================================== --- trunk/src/xml/rdf/map_to_tm.lisp (original) +++ trunk/src/xml/rdf/map_to_tm.lisp Mon Sep 7 04:44:19 2009 @@ -10,54 +10,320 @@ (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))) - )) + :document-id document-id)) + (associations-to-map (get-isi-topics + tm-id start-revision + :document-id document-id + :type-psi *tm2rdf-association-type-uri*))) + (let ((mapped-topics + (map 'list #'(lambda(top) + (map-isi-topic top start-revision)) + topics-to-map)) + (mapped-associations associations-to-map)) + + (append mapped-topics mapped-associations) + ;check-for-duplicate-identifiers + ;delete-construct: + ; *item-identifier-property + ; *subject-identifier-property + ; *subject-locator-proeprty* + ; *topic-type + ; *occurrence-type + ; *occurrence-property + ; *name-type + ; *name-property + ; *variant-type + ; *variant-property + ; *occurrence-type-property + ; *value-property + ; *scope-property + ; *nametype-property + ))) + + +(defun map-isi-topic(top start-revision) + "maps a passed topic with all its isidorus:types to a TM topic." + (declare (integer start-revision)) + (declare(TopicC top)) + (let ((new-psis (map-isi-identifiers + top start-revision + :id-type-uri *tm2rdf-subjectidentifier-property*)) + (new-locators (map-isi-identifiers + top start-revision + :id-type-uri *tm2rdf-subjectlocator-property*)) + (new-item-ids (map-isi-identifiers top start-revision)) + (occurrence-topics (get-isi-occurrences top start-revision)) + (name-topics (get-isi-names top start-revision))) + (bound-subject-identifiers top new-psis) + (bound-subject-locators top new-locators) + (bound-item-identifiers top new-item-ids) + (map 'list #'(lambda(occ-top) + (map-isi-occurrence top occ-top start-revision)) + occurrence-topics) + (map 'list #'(lambda(name-top) + (map-isi-name top name-top start-revision)) + name-topics)) + top) + + +(defun get-isi-variants(name-top start-revision) + "Returns all topics representing a name's variant." + (declare (TopicC name-top)) + (declare (integer start-revision)) + (let ((variant-assocs + (get-associations-by-type name-top start-revision + *tm2rdf-variant-property* + *rdf2tm-subject*))) + (let ((players + (get-players-by-role-type variant-assocs start-revision + *rdf2tm-object*))) + (map 'list #'d::delete-construct variant-assocs) + players))) + + +(defun map-isi-variant (name variant-top start-revision) + "Maps the passed variant-topic to a TM variant." + (declare (TopicC variant-top)) + (declare (NameC name)) + (declare (integer start-revision)) + (let ((ids (map-isi-identifiers variant-top start-revision)) + (scope-assocs + (get-associations-by-type + variant-top start-revision + (concatenate 'string *tm2rdf-ns* "scope") + *rdf2tm-subject*)) + (value-type-topic + (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (let ((scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (value-and-datatype + (let ((value-occ + (find-if #'(lambda(occ) + (eql (instance-of occ) value-type-topic)) + (occurrences variant-top)))) + (if value-occ + (list :value (charvalue value-occ) + :datatype (datatype value-occ)) + (list :value "" + :datatype *xml-string*))))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct scope-assocs) + (d::delete-construct variant-top) + (make-construct 'VariantC + :start-revision start-revision + :item-identifiers ids + :themes scopes + :charvalue (getf value-and-datatype :value) + :datatype (getf value-and-datatype :datatype) + :name name))))) + + +(defun map-isi-name (top name-top start-revision) + "Maps the passed occurrence-topic to a TM occurrence." + (declare (TopicC top name-top)) + (declare (integer start-revision)) + (let ((err-pref "From map-isi-name(): ") + (ids (map-isi-identifiers name-top start-revision)) + (type-assocs + (get-associations-by-type + name-top start-revision + (concatenate 'string *tm2rdf-ns* "nametype") + *rdf2tm-subject*)) + (scope-assocs + (get-associations-by-type + name-top start-revision + (concatenate 'string *tm2rdf-ns* "scope") + *rdf2tm-subject*)) + (value-type-topic + (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value"))) + (variant-topics (get-isi-variants name-top start-revision))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (value + (let ((value-occ + (find-if #'(lambda(occ) + (eql (instance-of occ) value-type-topic)) + (occurrences name-top)))) + (if value-occ + (charvalue value-occ) + "")))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct scope-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (let ((name (make-construct 'NameC + :start-revision start-revision + :topic top + :charvalue value + :instance-of (first types) + :item-identifiers ids + :themes scopes))) + (map 'list #'(lambda(variant-top) + (map-isi-variant name variant-top start-revision)) + variant-topics) + (d::delete-construct name-top) + name))))) + + +(defun get-isi-names(top start-revision) + "Returns all topics that represents names for the passed top." + (declare (TopicC top)) + (declare (integer start-revision)) + (let ((assocs (get-associations-by-type + top start-revision *tm2rdf-name-property* + *rdf2tm-subject*))) + (let ((occ-tops (get-players-by-role-type + assocs start-revision *rdf2tm-object*))) + (map 'list #'d::delete-construct assocs) + occ-tops))) + + +(defun map-isi-occurrence(top occ-top start-revision) + "Maps all topics that represents occurrences of the passed topic top + to occurrence objects." + (declare (TopicC top occ-top)) + (declare (integer start-revision)) + (let ((err-pref "From map-isi-occurrence(): ") + (ids (map-isi-identifiers occ-top start-revision)) + (type-assocs + (get-associations-by-type + occ-top start-revision + (concatenate 'string *tm2rdf-ns* "occurrencetype") + *rdf2tm-subject*)) + (scope-assocs + (get-associations-by-type + occ-top start-revision + (concatenate 'string *tm2rdf-ns* "scope") + *rdf2tm-subject*)) + (value-type-topic + (get-item-by-psi (concatenate 'string *tm2rdf-ns* "value")))) + (let ((types (get-players-by-role-type + type-assocs start-revision *rdf2tm-object*)) + (scopes (get-players-by-role-type + scope-assocs start-revision *rdf2tm-object*)) + (value-and-datatype + (let ((value-occ + (find-if #'(lambda(occ) + (eql (instance-of occ) value-type-topic)) + (occurrences occ-top)))) + (if value-occ + (list :value (charvalue value-occ) + :datatype (datatype value-occ)) + (list :value "" + :datatype *xml-string*))))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct type-assocs) + (map 'list #'d::delete-construct scope-assocs) + (when (/= 1 (length types)) + (error "~aexpect one type topic but found: ~a" + err-pref (length types))) + (d::delete-construct occ-top) + (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes scopes + :item-identifiers ids + :instance-of (first types) + :charvalue (getf value-and-datatype :value) + :datatype (getf value-and-datatype :datatype)))))) + + +(defun get-isi-occurrences(top start-revision) + "Returns all topics that represents occurrences for the passed top." + (declare (TopicC top)) + (declare (integer start-revision)) + (let ((assocs (get-associations-by-type + top start-revision *tm2rdf-occurrence-property* + *rdf2tm-subject*))) + (let ((occ-tops (get-players-by-role-type + assocs start-revision *rdf2tm-object*))) + (map 'list #'d::delete-construct assocs) + occ-tops))) (defun get-isi-topics (tm-id start-revision - &key (document-id *document-id*)) + &key (document-id *document-id*) + (type-psi *tm2rdf-topic-type-uri*)) "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 + (let ((type-topic (get-item-by-psi type-psi + :revision start-revision))) + (when type-topic + (let ((assocs (get-associations-by-type + type-topic start-revision *type-instance-psi* + *type-psi*))) + (let ((isi-topics (get-players-by-role-type + assocs start-revision *instance-psi*))) + (let ((topics-in-tm + (with-tm (start-revision document-id tm-id) + (intersection isi-topics (topics xml-importer::tm))))) + (map 'list #'(lambda(top) + (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))))))))) + (when (find (parent role) assocs) + (d::delete-construct (parent role)))) + (player-in-roles top))) + topics-in-tm) + topics-in-tm)))))) -(defun map-isi-identifiers (top start-revision - &key (prop-uri *tm2rdf-itemIdentity-property*)) +(defun get-associations-by-type (top start-revision association-type-psi + role-type-psi) + "Returns all associations of the passed associaiton type where the + topic top is a player in a role of the given roletype." + (declare (TopicC top)) + (declare (string association-type-psi role-type-psi)) + (declare (integer start-revision)) + (let ((assoc-type (get-item-by-psi association-type-psi + :revision start-revision)) + (role-type (get-item-by-psi role-type-psi + :revision start-revision))) + (when (and assoc-type role-type) + (let ((assocs + (remove-if + #'null + (map 'list + #'(lambda(role) + (when (and (eql (instance-of (parent role)) assoc-type) + (eql (instance-of role) role-type)) + (parent role))) + (player-in-roles top))))) + assocs)))) + + +(defun get-players-by-role-type (associations start-revision + role-type-psi) + "Returns all players of the passed associaiton that are contained + in roles of the given type." + (declare (list associations)) + (declare (integer start-revision)) + (declare (string role-type-psi)) + (let ((role-type (get-item-by-psi role-type-psi + :revision start-revision))) + (let ((players + (remove-if + #'null + (map 'list + #'(lambda(assoc) + (let ((role + (find-if #'(lambda(role) + (eql role-type (instance-of role))) + (roles assoc)))) + (when role + (player role)))) + associations)))) + players))) + + + +(defun get-occurrences-by-type (top start-revision + &key (occurrence-type-uri + *tm2rdf-itemIdentity-property*)) + "Returns all occurrences of the given topic, that is of the type + bound to occurrence-type-uri." (declare (TopicC top)) (with-revision start-revision (let ((identifier-occs @@ -67,11 +333,69 @@ (let ((type (instance-of occurrence))) (let ((type-psi (find-if #'(lambda(psi) - (string= prop-uri - (uri psi))) + (string= + occurrence-type-uri + (uri psi))) (psis type)))) - (format t "~a~%" type-psi) (when type-psi occurrence)))) (occurrences top))))) - identifier-occs))) \ No newline at end of file + identifier-occs))) + + +(defun map-isi-identifiers (top start-revision + &key (id-type-uri + *tm2rdf-itemIdentity-property*)) + "Maps identifiers of the type depending on id-type-uri from topic occurrences + imported from RDF to the corresponding TM constructs." + (declare (TopicC top)) + (let ((id-occs (get-occurrences-by-type top start-revision + :occurrence-type-uri id-type-uri)) + (class-symbol (cond + ((string= id-type-uri + *tm2rdf-itemIdentity-property*) + 'ItemIdentifierC) + ((string= id-type-uri + *tm2rdf-subjectLocator-property*) + 'SubjectLocatorC) + ((string= id-type-uri + *tm2rdf-subjectIdentifier-property*) + 'PersistentIdC)))) + (let ((id-uris (map 'list #'charvalue id-occs))) + (elephant:ensure-transaction (:txn-nosync t) + (map 'list #'d::delete-construct id-occs) + (let ((ids (map 'list + #'(lambda(id-uri) + (make-instance class-symbol + :uri id-uri + :start-revision start-revision)) + id-uris))) + ids))))) + + +(defun bound-item-identifiers (construct identifiers) + "Bounds the passed item-identifier to the passed construct." + (declare (ReifiableConstructC construct)) + (dolist (id identifiers) + (declare (ItemIdentifierC id)) + (setf (identified-construct id) construct)) + construct) + + +(defun bound-subject-identifiers (top identifiers) + "Bounds the passed psis to the passed topic." + (declare (TopicC top)) + (dolist (id identifiers) + (declare (PersistentIdC id)) + (setf (identified-construct id) top)) + top) + + +(defun bound-subject-locators (top locators) + "Bounds the passed locators to the passed topic." + (declare (TopicC top)) + (dolist (id locators) + (declare (SubjectLocatorC id)) + (setf (identified-construct id) top)) + top) + Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Sep 7 04:44:19 2009 @@ -45,7 +45,8 @@ *tm2rdf-association-property* *tm2rdf-subjectIdentifier-property* *tm2rdf-itemIdentity-property* - *tm2rdf-subjectLocator-property*) + *tm2rdf-subjectLocator-property* + *tm2rdf-ns*) (:import-from :xml-constants *rdf_core_psis.xtm* *core_psis.xtm*)

1 0

[isidorus-cvs] r132 - in trunk/src: . model unit_tests xml/rdf
by Lukas Giessmann 05 Sep '09

05 Sep '09

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/\">" - " <sw:Node rdf:about=\"http://sw/node\"" - " rdf:type=\"http://sw/Node-1\">" - " <sw:type rdf:resource=\"anyResource\"/>" - " <rdf:type rdf:resource=\"Node-2\"/>" - " <rdf:type rdf:resource=\"http://sw/Node-3\"/>" - " <rdf:type rdf:nodeID=\"anyType\"/>" - " </sw:Node>" - - " <rdf:Description rdf:about=\"http://sw/emtpy\"/>" - "</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/\">" - " <rdf:Description rdf:nodeID=\"anyNode\">" - " <rdf:type rdf:resource=\"http://type-1\"/>" - " <sw:arc>" - " <rdf:Description rdf:nodeID=\"anyNode\" " - " rdf:type=\"http://type-2\"/>" - " </sw:arc>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID=\"anotherNode\">" - " <rdf:type rdf:resource=\"http://type-3\"/>" - " </rdf:Description>" - - " <sw:NodeType rdf:nodeID=\"anyNode\"/>" - - " <rdf:Description rdf:nodeID=\"anyNode\" " - " rdf:datatype=\"anyDatatype\">" - " <rdf:type rdf:resource=\"http://type-7\"/>" - " </rdf:Description>" - - " <rdf:Description rdf:about=\"http://a-node\">" - " <sw:arc>" - " <rdf:Description rdf:about=\"http://b-node\">" - " <rdf:type rdf:resource=\"http://type-5\"/>" - " <rdf:arc>" - " <rdf:Description rdf:nodeID=\"anyNode\">" - " <rdf:type rdf:resource=\"http://type-5\"/>" - " <rdf:type rdf:resource=\"http://type-6\"/>" - " </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/\" " - "xmlns:isi=\"" *tm2rdf-ns* "\">" - " <isi:Topic rdf:about=\"http://node-1\">" - " <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/\">" - " <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/\"" - " 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/\"" - " xmlns:isi=\"" *tm2rdf-ns* "\">" - " <rdf:Description rdf:about=\"http://node-1\">" - " <isi:subjectIdentifier>http://topic-psi-1</isi:subjectIdentifier>" - " <isi:subjectLocator>http://topic-sl-1</isi:subjectLocator>" - " <isi:itemIdentity>http://topic-ii-1</isi:itemIdentity>" - " <sw:arc rdf:resource=\"http://resource-1\"/>" - " <isi:name>" - " <isi:Name>" - " <isi:itemIdentity>http://itemIdentity-1</isi:itemIdentity>" - " <isi:itemIdentity>http://itemIdentity-2</isi:itemIdentity>" - " <isi:scope rdf:resource=\"http://scope-1\"/>" - " <isi:scope rdf:resource=\"http://scope-2\"/>" - " <isi:value rdf:datatype=\"anyDatatype\">value-1</isi:value>" - " <isi:nametype rdf:resource=\"http://nametype-1\"/>" - " <isi:variant rdf:nodeID=\"variant-1\"/>" - " </isi:Name>" - " </isi:name>" - " <isi:name rdf:parseType=\"Resource\">" - " <rdf:type rdf:resource=\"" *tm2rdf-name-type-uri* "\"/>" - " <isi:itemIdentity>http://itemIdentity-4</isi:itemIdentity>" - " <isi:value rdf:datatype=\"anyDatatype\">value-3</isi:value>" - " <isi:nametype rdf:resource=\"http://nametype-2\"/>" - " <isi:variant rdf:parseType=\"Resource\">" - " <rdf:type>" - " <rdf:Description rdf:about=\"" *tm2rdf-variant-type-uri* "\"/>" - " </rdf:type>" - " <isi:value>value-4</isi:value>" - " <isi:scope>" - " <rdf:Description rdf:about=\"http://scope-3\"/>" - " </isi:scope>" - " </isi:variant>" - " </isi:name>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID=\"variant-1\">" - " <isi:scope rdf:resource=\"http://scope-3\"/>" - " <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\"/>" - " </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/\"" - " xmlns:isi=\"" *tm2rdf-ns* "\">" - " <rdf:Description rdf:about=\"http://node-1\">" - " <sw:arc rdf:resource=\"http://resource-1\"/>" - " <isi:occurrence rdf:type=\"http://isidorus/tm2rdf_mapping/Occurrence\">" - " <isi:occurrencetype rdf:resource=\"http://occurrence-1\"/>" - " <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\"/>" - " <isi:scope rdf:resource=\"http://scope-1\"/>" - " </isi:Occurrence>" - " </isi:occurrence>" - " <isi:occurrence rdf:parseType=\"Resource\">" - " <rdf:type rdf:resource=\"" *tm2rdf-occurrence-type-uri* "\"/>" - " <isi:occurrencetype rdf:resource=\"http://occurrence-3\"/>" - " " - " </isi:occurrence>" - " </rdf:Description>" - - " <rdf:Description rdf:nodeID=\"occurrence-2\">" - " <isi:scope rdf:resource=\"http://scope-2\"/>" - " <isi:value>value-2</isi:value>" - " <isi:occurrencetype rdf:resource=\"http://occurrence-2\"/>" - " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-1</isi:itemIdentity>" - " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-2</isi:itemIdentity>" - " <isi:shouldBeIgnored>anyText</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/\"" - " 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\"/>" - " <isi:scope>" - " <rdf:Description rdf:about=\"http://scope-1\">" - " <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\"/>" - " <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\"/>" - " <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\"/>" - " <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\"/>" - " </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"))))))) - -

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs September 2009