[isidorus-cvs] r113 - in trunk/src: . unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Aug 13 19:47:54 UTC 2009
Author: lgiessmann
Date: Thu Aug 13 15:47:53 2009
New Revision: 113
Log:
rdf-importer: finalized the rdf-importer -> collections are imported as linked lists modelled as tm-associations (equal to manual created rdf-collections
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_core_psis.xtm
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp (original)
+++ trunk/src/constants.lisp Thu Aug 13 15:47:53 2009
@@ -37,7 +37,6 @@
:*rdf-rest*
:*rdf2tm-object*
:*rdf2tm-subject*
- :*rdf2tm-collection*
:*rdf2tm-scope-prefix*))
(in-package :constants)
@@ -95,6 +94,4 @@
(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping#subject")
-(defparameter *rdf2tm-collection* "http://isidorus/rdf2tm_mapping#collection")
-
(defparameter *rdf2tm-scope-prefix* "http://isidorus/rdf2tm_mapping/scope#")
\ No newline at end of file
Modified: trunk/src/unit_tests/rdf_importer_test.lisp
==============================================================================
--- trunk/src/unit_tests/rdf_importer_test.lisp (original)
+++ trunk/src/unit_tests/rdf_importer_test.lisp Thu Aug 13 15:47:53 2009
@@ -57,7 +57,9 @@
:test-poems-rdf-occurrences
:test-poems-rdf-associations
:test-poems-rdf-typing
- :test-poems-rdf-topics))
+ :test-poems-rdf-topics
+ :test-empty-collection
+ :test-collection))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -1034,7 +1036,7 @@
(rdf-init-db :db-dir db-dir :start-revision revision-1)
(rdf-importer::import-node node tm-id revision-2
:document-id document-id)
- (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 21))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20))
(let ((first-node (get-item-by-id "http://test-tm/first-node"
:xtm-id document-id))
(first-type (get-item-by-id "http://test-tm/first-type"
@@ -1472,8 +1474,8 @@
2))
(rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
:document-id document-id)
- (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 38))
- (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 10))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 40))
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 12))
(setf rdf-importer::*current-xtm* document-id)
(is (= (length
(intersection
@@ -1482,7 +1484,7 @@
(list
(d:get-item-by-id (concatenate
'string
- constants::*rdf2tm-collection*)
+ constants::*rdf-nil*)
:xtm-id rdf-importer::*rdf-core-xtm*)
(d:get-item-by-psi constants::*type-instance-psi*)
(dotimes (iter 9)
@@ -1515,8 +1517,9 @@
constants:*type-instance-psi*))
(subject (d:get-item-by-psi constants::*rdf2tm-subject*))
(object (d:get-item-by-psi constants::*rdf2tm-object*))
- (collection (d:get-item-by-id
- constants::*rdf2tm-collection*)))
+ (rdf-first (d:get-item-by-psi constants:*rdf-first*))
+ (rdf-rest (d:get-item-by-psi constants:*rdf-rest*))
+ (rdf-nil (d:get-item-by-psi constants:*rdf-nil*)))
(is (= (length (d:psis first-node)) 1))
(is (string= (d:uri (first (d:psis first-node)))
"http://test-tm/first-node"))
@@ -1560,6 +1563,15 @@
(is (= (length (d:psis arc8)) 1))
(is (string= (d:uri (first (d:psis arc8)))
"http://test/arcs/arc8"))
+ (is (= (length (d:psis rdf-first)) 1))
+ (is (string= (d:uri (first (d:psis rdf-first)))
+ constants:*rdf-first*))
+ (is (= (length (d:psis rdf-rest)) 1))
+ (is (string= (d:uri (first (d:psis rdf-rest)))
+ constants:*rdf-rest*))
+ (is (= (length (d:psis rdf-nil)) 1))
+ (is (string= (d:uri (first (d:psis rdf-nil)))
+ constants:*rdf-nil*))
(is (= (length (elephant:get-instances-by-class 'd:OccurrenceC))
1))
(is (string= (d:charvalue (first (elephant:get-instances-by-class
@@ -1629,30 +1641,84 @@
(eql (d:instance-of (d:parent x)) arc4)))
(d:player-in-roles uuid-1))))))))
(is-true col-1)
- (is (= (length (d:player-in-roles col-1)) 2))
+ (is (= (length (d:player-in-roles col-1)) 3))
(is-true (find-if
#'(lambda(x)
(and (eql (d:instance-of x) subject)
(eql (d:instance-of (d:parent x))
- collection)))
+ rdf-first)))
(d:player-in-roles col-1)))
- (let ((col-assoc
- (d:parent
- (find-if
+ (is-true (find-if
#'(lambda(x)
(and (eql (d:instance-of x) subject)
(eql (d:instance-of (d:parent x))
- collection)))
- (d:player-in-roles col-1)))))
- (is-true col-assoc)
- (is (= (length (d:roles col-assoc)) 3))
- (is (= (count-if
+ rdf-rest)))
+ (d:player-in-roles col-1)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x))
+ arc4)))
+ (d:player-in-roles col-1)))
+ (is (= (length (d:player-in-roles item-1)) 1))
+ (is-true (find-if
#'(lambda(x)
(and (eql (d:instance-of x) object)
- (or (eql (d:player x) item-1)
- (eql (d:player x) item-2))))
- (d:roles col-assoc))
- 2))))
+ (eql (d:instance-of (d:parent x))
+ rdf-first)))
+ (d:player-in-roles item-1)))
+ (let ((col-2
+ (let ((role
+ (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x))
+ rdf-rest)))
+ (d:player-in-roles col-1))))
+ (is (= (length (d:roles (d:parent role))) 2))
+ (let ((other-role
+ (find-if #'(lambda(x)
+ (and (not (eql x role))
+ (eql (d:instance-of x)
+ object)))
+ (d:roles (d:parent role)))))
+ (d:player other-role)))))
+ (is-true col-2)
+ (is (= (length (d:psis col-2)) 0))
+ (is (= (length (d:player-in-roles col-2)) 3))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x))
+ rdf-first)))
+ (d:player-in-roles col-2)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x))
+ rdf-rest)))
+ (d:player-in-roles col-2)))
+ (let ((col-3
+ (let ((role
+ (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x))
+ rdf-rest)))
+ (d:player-in-roles col-2))))
+
+ (is (= (length (d:roles (d:parent role))) 2))
+ (let ((other-role
+ (find-if
+ #'(lambda(x)
+ (not (eql x role)))
+ (d:roles (d:parent role)))))
+ (d:player other-role)))))
+ (is-true col-3)
+ (is (= (length (d:psis col-3)) 1))
+ (is (string= (d:uri (first (d:psis col-3)))
+ constants:*rdf-nil*))
+ (is (= (length (d:player-in-roles col-3)) 2)))))
(is (= (length (d:player-in-roles item-1)) 1))
(is (= (length (d:player-in-roles item-2)) 2))
(is-true (find-if
@@ -1689,12 +1755,13 @@
4))
(is (= (length (d:player-in-roles fourth-node)) 1))
(is (= (length (d:player-in-roles fifth-node)) 1))
+ (format t "--->")
(let ((col-2
(d:player
(find-if
#'(lambda(y)
(and (eql (d:instance-of y) object)
- (= 0 (length (d:psis (d:player y))))))
+ (= 1 (length (d:psis (d:player y))))))
(d:roles
(d:parent
(find-if
@@ -1702,24 +1769,11 @@
(and (eql (d:instance-of x) subject)
(eql (d:instance-of (d:parent x)) arc8)))
(d:player-in-roles uuid-2))))))))
+ (is (= (length (d:psis col-2)) 1))
+ (is (string= constants:*rdf-nil*
+ (d:uri (first (d:psis col-2)))))
(is-true col-2)
- (is (= (length (d:player-in-roles col-2)) 2))
- (is-true (find-if
- #'(lambda(x)
- (and (eql (d:instance-of x) subject)
- (eql (d:instance-of (d:parent x))
- collection)))
- (d:player-in-roles col-2)))
- (let ((col-assoc
- (d:parent
- (find-if
- #'(lambda(x)
- (and (eql (d:instance-of x) subject)
- (eql (d:instance-of (d:parent x))
- collection)))
- (d:player-in-roles col-2)))))
- (is-true col-assoc)
- (is (= (length (d:roles col-assoc)) 1))))))))))
+ (is (= (length (d:player-in-roles col-2)) 2)))))))))
(elephant:close-store))
@@ -1742,7 +1796,7 @@
(date "http://www.w3.org/2001/XMLSchema#date")
(de (d:get-item-by-id "http://isidorus/rdf2tm_mapping/scope#de"))
(long "http://www.w3.org/2001/XMLSchema#unsignedLong"))
- (is (= (length topics) 66))
+ (is (= (length topics) 65))
(is (= (length occs) 23))
(is (= (length assocs) 30))
(is-true de)
@@ -2350,9 +2404,7 @@
(zauberlehrling "http://some.where/poem/Der_Zauberlehrling")
(prometheus "http://some.where/poem/Prometheus")
(erlkoenig "http://some.where/ballad/Der_Erlkoenig")
- (country "http://some.where/types/Country")
-
- )
+ (country "http://some.where/types/Country"))
(is (= (count-if
#'(lambda(x)
(and (eql (d:instance-of x) supertype-subtype)
@@ -2708,6 +2760,227 @@
6))))))
+(test test-empty-collection
+ "Tests importing of empty collections."
+ (let ((db-dir "data_base")
+ (tm-id "http://test-tm/")
+ (revision-1 100)
+ (document-id "doc-id")
+ (doc-1
+ (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\">"
+ " <rdf:Description rdf:about=\"first-node\">"
+ " <arcs:arc rdf:parseType=\"Collection\" />"
+ " </rdf:Description>"
+ "</rdf:RDF>")))
+ (let ((rdf-node (elt (dom:child-nodes
+ (cxml:parse doc-1 (cxml-dom:make-dom-builder)))
+ 0)))
+ (is-true rdf-node)
+ (rdf-init-db :db-dir db-dir :start-revision revision-1)
+ (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
+ :document-id document-id)
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 21))
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1))
+ (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 0))
+ (is (= (length (elephant:get-instances-by-class 'd:NameC)) 0))
+ (let ((first-node (d:get-item-by-id "http://test-tm/first-node"
+ :xtm-id document-id))
+ (arc (d:get-item-by-id "http://test/arcs/arc"
+ :xtm-id document-id))
+ (rdf-nil (d:get-item-by-id constants:*rdf-nil*
+ :xtm-id document-id))
+ (subject (d:get-item-by-id constants:*rdf2tm-subject*))
+ (object (d:get-item-by-id constants:*rdf2tm-object*)))
+ (is-true subject)
+ (is-true object)
+ (is-true first-node)
+ (is (= (length (d:psis first-node)) 1))
+ (is (string= (d:uri (first (d:psis first-node)))
+ "http://test-tm/first-node"))
+ (is-true arc)
+ (is (= (length (d:psis arc)) 1))
+ (is (string= (d:uri (first (d:psis arc)))
+ "http://test/arcs/arc"))
+ (is-true rdf-nil)
+ (is (= (length (d:psis rdf-nil)) 1))
+ (is (string= (d:uri (first (d:psis rdf-nil))) constants:*rdf-nil*))
+ (is (= (length (d:player-in-roles first-node)) 1))
+ (is (= (length (d:player-in-roles arc)) 0))
+ (is (= (length (d:player-in-roles rdf-nil)) 1))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x)) arc)))
+ (d:player-in-roles first-node)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x)) arc)))
+ (d:player-in-roles rdf-nil)))))))
+
+
+(test test-collection
+ "Tests importing of non-empty collections."
+ (let ((db-dir "data_base")
+ (tm-id "http://test-tm/")
+ (revision-1 100)
+ (document-id "doc-id")
+ (doc-1
+ (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\">"
+ " <rdf:Description rdf:about=\"first-node\">"
+ " <arcs:arc rdf:parseType=\"Collection\">"
+ " <rdf:Description rdf:about=\"item-1\"/>"
+ " <arcs:Node rdf:about=\"item-2\"/>"
+ " </arcs:arc>"
+ " </rdf:Description>"
+ "</rdf:RDF>")))
+ (let ((rdf-node (elt (dom:child-nodes
+ (cxml:parse doc-1 (cxml-dom:make-dom-builder)))
+ 0)))
+ (is-true rdf-node)
+ (rdf-init-db :db-dir db-dir :start-revision revision-1)
+ (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
+ :document-id document-id)
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28))
+ (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 6))
+ (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 0))
+ (is (= (length (elephant:get-instances-by-class 'd:NameC)) 0))
+ (let ((first-node (d:get-item-by-id "http://test-tm/first-node"
+ :xtm-id document-id))
+ (arc (d:get-item-by-id "http://test/arcs/arc"
+ :xtm-id document-id))
+ (item-1 (d:get-item-by-id "http://test-tm/item-1"
+ :xtm-id document-id))
+ (item-2 (d:get-item-by-id "http://test-tm/item-2"
+ :xtm-id document-id))
+ (node (d:get-item-by-id "http://test/arcs/Node"
+ :xtm-id document-id))
+ (rdf-first (d:get-item-by-id constants:*rdf-first*
+ :xtm-id document-id))
+ (rdf-rest (d:get-item-by-id constants:*rdf-rest*
+ :xtm-id document-id))
+ (rdf-nil (d:get-item-by-id constants:*rdf-nil*
+ :xtm-id document-id))
+ (subject (d:get-item-by-id constants:*rdf2tm-subject*
+ :xtm-id document-id))
+ (object (d:get-item-by-id constants:*rdf2tm-object*
+ :xtm-id document-id))
+ (instance (d:get-item-by-psi constants:*instance-psi*))
+ (type (d:get-item-by-psi constants:*type-psi*))
+ (type-instance (d:get-item-by-psi constants:*type-instance-psi*)))
+ (is-true first-node)
+ (is (= (length (d:psis first-node)) 1))
+ (is (string= (d:uri (first (d:psis first-node)))
+ "http://test-tm/first-node"))
+ (is (= (length (d:player-in-roles first-node)) 1))
+ (is-true arc)
+ (is (= (length (d:psis arc)) 1))
+ (is (string= (d:uri (first (d:psis arc)))
+ "http://test/arcs/arc"))
+ (is (= (length (d:player-in-roles arc)) 0))
+ (is-true item-1)
+ (is (= (length (d:psis item-1)) 1))
+ (is (string= (d:uri (first (d:psis item-1)))
+ "http://test-tm/item-1"))
+ (is (= (length (d:player-in-roles item-1)) 1))
+ (is-true item-2)
+ (is (= (length (d:psis item-2)) 1))
+ (is (string= (d:uri (first (d:psis item-2)))
+ "http://test-tm/item-2"))
+ (is (= (length (d:player-in-roles item-2)) 2))
+ (is-true node)
+ (is (= (length (d:psis node)) 1))
+ (is (string= (d:uri (first (d:psis node)))
+ "http://test/arcs/Node"))
+ (is (= (length (d:player-in-roles node)) 1))
+ (is-true rdf-first)
+ (is-true rdf-rest)
+ (is-true rdf-nil)
+ (is (= (length (d:player-in-roles rdf-nil)) 1))
+ (is-true subject)
+ (is-true object)
+ (let ((uuid-1
+ (d:player
+ (find-if
+ #'(lambda(x)
+ (not (eql x (first (d:player-in-roles first-node)))))
+ (d:roles (d:parent (first (d:player-in-roles first-node)))))))
+ (uuid-2
+ (d:player
+ (find-if
+ #'(lambda(x)
+ (not (eql x (first (d:player-in-roles rdf-nil)))))
+ (d:roles (d:parent (first (d:player-in-roles rdf-nil))))))))
+ (is-true uuid-1)
+ (is (= (length (d:psis uuid-1)) 0))
+ (is (= (length (d:player-in-roles uuid-1)) 3))
+ (is-true uuid-2)
+ (is (= (length (d:psis uuid-2)) 0))
+ (is (= (length (d:player-in-roles uuid-2)) 3))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x)) arc)))
+ (d:player-in-roles first-node)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x)) arc)))
+ (d:player-in-roles uuid-1)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x)) rdf-first)))
+ (d:player-in-roles uuid-1)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x)) rdf-rest)))
+ (d:player-in-roles uuid-1)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x)) rdf-first)))
+ (d:player-in-roles item-1)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x)) rdf-rest)))
+ (d:player-in-roles uuid-2)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x)) rdf-first)))
+ (d:player-in-roles uuid-2)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) subject)
+ (eql (d:instance-of (d:parent x)) rdf-rest)))
+ (d:player-in-roles uuid-2)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x)) rdf-rest)))
+ (d:player-in-roles rdf-nil)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) object)
+ (eql (d:instance-of (d:parent x)) rdf-first)))
+ (d:player-in-roles item-2)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) instance)
+ (eql (d:instance-of (d:parent x)) type-instance)))
+ (d:player-in-roles item-2)))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (eql (d:instance-of x) type)
+ (eql (d:instance-of (d:parent x)) type-instance)))
+ (d:player-in-roles node))))))))
+
+
(defun run-rdf-importer-tests()
(when elephant:*store-controller*
(elephant:close-store))
@@ -2726,4 +2999,6 @@
(it.bese.fiveam:run! 'test-poems-rdf-occurrences)
(it.bese.fiveam:run! 'test-poems-rdf-associations)
(it.bese.fiveam:run! 'test-poems-rdf-typing)
- (it.bese.fiveam:run! 'test-poems-rdf-topics))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-poems-rdf-topics)
+ (it.bese.fiveam:run! 'test-empty-collection)
+ (it.bese.fiveam:run! 'test-collection))
\ No newline at end of file
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Thu Aug 13 15:47:53 2009
@@ -101,8 +101,6 @@
(format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove
(tm-id-p tm-id "import-node")
(parse-node elem)
- ;TODO: handle Collections that are made manually without
- ; parseType="Collection" -> see also import-arc
(let ((fn-xml-base (get-xml-base elem :old-base xml-base))
(fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
(let ((about (get-absolute-attribute elem tm-id xml-base "about"))
@@ -158,76 +156,123 @@
(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")))
- (when (or (not parseType)
- (and parseType
- (string/= parseType "Collection")))
- (when UUID
- (parse-properties-of-node elem UUID)
- (with-tm (start-revision document-id tm-id)
- (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))))))
- (make-recursion-from-arc elem tm-id start-revision
- :document-id document-id
- :xml-base xml-base :xml-lang xml-lang)))
+ (parseType (get-ns-attribute elem "parseType"))
+ (content (child-nodes-or-text elem :trim t)))
+ (with-tm (start-revision document-id tm-id)
+ (if (and (string= parseType "Collection")
+ (= (length content) 0))
+ (make-topic-stub *rdf-nil* nil nil nil start-revision
+ xml-importer::tm :document-id document-id)
+ (let ((this-topic
+ (when (or (not parseType)
+ (and parseType
+ (string/= parseType "Collection")))
+ (when UUID
+ (parse-properties-of-node elem UUID)
+ (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)
+ this-topic)))))
-(defun make-collection (elem owner-top tm-id start-revision
+(defun make-collection (elem tm-id start-revision
&key (document-id *document-id*)
(xml-base nil) (xml-lang nil))
- "Creates a TM association with a subject role containing the collection
- entry point and as many roles of the type 'object' as items exists."
- (declare (d:TopicC owner-top))
+ "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))
- (subject (make-topic-stub *rdf2tm-subject* nil nil nil start-revision
- xml-importer::tm :document-id document-id))
- (object (make-topic-stub *rdf2tm-object* nil nil nil start-revision
- xml-importer::tm :document-id document-id)))
- (let ((association-type (make-topic-stub *rdf2tm-collection* nil nil nil
- start-revision xml-importer::tm
- :document-id document-id))
- (roles
- (append
- (loop for item across (child-nodes-or-text elem :trim t)
- collect (let ((item-top (import-node item tm-id start-revision
- :document-id document-id
- :xml-base fn-xml-base
- :xml-lang fn-xml-lang)))
- (list :player item-top
- :instance-of object)))
- (list (list :player owner-top
- :instance-of subject)))))
- (add-to-topicmap
- xml-importer::tm
- (make-construct 'd:AssociationC
- :start-revision start-revision
- :instance-of association-type
- :roles roles))))))
+ (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
+ (let ((this (make-topic-stub nil nil nil UUID start-revision
+ xml-importer::tm
+ :document-id document-id))
+ (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))))
+ (let ((last-blank-node this))
+ (dotimes (index (length items))
+ (let ((is-end
+ (if (= index (- (length items) 1))
+ t
+ nil)))
+ (let ((new-blank-node
+ (make-collection-association
+ last-blank-node (elt items index) tm-id start-revision
+ :is-end is-end :document-id document-id)))
+ (setf last-blank-node new-blank-node)))))))))
+
+
+(defun make-collection-association (current-blank-node first-object tm-id
+ start-revision &key (is-end nil)
+ (document-id *document-id*))
+ "Creates a 'first'-association between the current-blank-node and the
+ first-object. If is-end is set to true another association between
+ current-blank-node and the topic rdf:nil is created. Otherwise this
+ associaiton is made from the current-blank-node to a new created blank
+ node."
+ (declare (d:TopicC current-blank-node first-object))
+ (with-tm (start-revision document-id tm-id)
+ (let ((first-arc
+ (make-topic-stub *rdf-first* nil nil nil start-revision
+ xml-importer::tm :document-id document-id))
+ (rest-arc
+ (make-topic-stub *rdf-rest* nil nil nil start-revision
+ xml-importer::tm :document-id document-id)))
+ (make-association-with-nodes current-blank-node first-object first-arc
+ xml-importer::tm start-revision
+ :document-id document-id)
+ (if is-end
+ (let ((rdf-nil (make-topic-stub *rdf-nil* nil nil nil
+ start-revision xml-importer::tm
+ :document-id document-id)))
+ (make-association-with-nodes
+ current-blank-node rdf-nil rest-arc xml-importer::tm
+ start-revision :document-id document-id)
+ nil)
+ (let ((new-blank-node (make-topic-stub
+ nil nil nil (get-uuid) start-revision
+ xml-importer::tm :document-id document-id)))
+ (make-association-with-nodes
+ current-blank-node new-blank-node rest-arc xml-importer::tm
+ start-revision :document-id document-id)
+ new-blank-node)))))
(defun make-literals (owner-top literals tm-id start-revision
@@ -801,10 +846,15 @@
(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 fn-xml-base))
+ (content (child-nodes-or-text property :trim t))
+ (parseType (get-ns-attribute property "parseType")))
(let ((resource
- (get-absolute-attribute property tm-id
- fn-xml-base "resource"))
+ (if (and (string= parseType "Collection")
+ (= (length content) 0))
+ *rdf-nil*
+ (get-absolute-attribute property tm-id
+ fn-xml-base "resource")))
(nodeID (get-ns-attribute property "nodeID"))
(UUID (get-ns-attribute property "UUID"
:ns-uri *rdf2tm-ns*))
@@ -813,7 +863,7 @@
(full-name (get-type-of-node-name property)))
(if (or nodeID resource UUID)
(list :type full-name
- :topicid (or nodeID resource UUID)
+ :topicid (or resource nodeID UUID)
:psi resource
:ID ID)
(let ((refs (get-node-refs
@@ -851,8 +901,7 @@
(let ((fn-xml-base (get-xml-base arc :old-base xml-base))
(fn-xml-lang (get-xml-lang arc :old-lang xml-lang))
(content (child-nodes-or-text arc))
- (parseType (get-ns-attribute arc "parseType"))
- (UUID (get-ns-attribute arc "UUID" :ns-uri *rdf2tm-ns*)))
+ (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"))
@@ -860,32 +909,27 @@
(literals (get-literals-of-property arc xml-lang)))
(if (and parseType
(string= parseType "Collection"))
- (let ((this
- (with-tm (start-revision document-id tm-id)
- (make-topic-stub nil nil nil UUID start-revision
- xml-importer::tm
- :document-id document-id))))
- (make-collection arc this tm-id start-revision
- :document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang))
+ (make-collection arc tm-id start-revision
+ :document-id document-id
+ :xml-base xml-base
+ :xml-lang xml-lang)
(if (or datatype resource nodeID
(and parseType
(string= parseType "Literal"))
(and content
(stringp content)))
- t;; do nothing current elem is a literal node that has been
- ;; already imported as an occurrence
+ nil;; do nothing current elem is a literal node that has been
+ ;; already imported as an occurrence
(if (or type literals
(and parseType
(string= parseType "Resource")))
(loop for item across content
- do (import-arc item tm-id start-revision
- :document-id document-id
- :xml-base fn-xml-base
- :xml-lang fn-xml-lang))
+ collect (import-arc item tm-id start-revision
+ :document-id document-id
+ :xml-base fn-xml-base
+ :xml-lang fn-xml-lang))
(loop for item across content
- do (import-node item tm-id start-revision
- :document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang))))))))
+ 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
Modified: trunk/src/xml/rdf/rdf_core_psis.xtm
==============================================================================
--- trunk/src/xml/rdf/rdf_core_psis.xtm (original)
+++ trunk/src/xml/rdf/rdf_core_psis.xtm Thu Aug 13 15:47:53 2009
@@ -23,13 +23,6 @@
<value>object</value>
</name>
</topic>
-
- <topic id="collection">
- <subjectIdentifier href="http://isidorus/rdf2tm_mapping#collection"/>
- <name>
- <value>object</value>
- </name>
- </topic>
<topic id="supertype-subtype">
<subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype-subtype"/>
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Thu Aug 13 15:47:53 2009
@@ -31,7 +31,6 @@
*rdf-nil*
*rdf-first*
*rdf-rest*
- *rdf2tm-collection*
*rdf2tm-scope-prefix*)
(:import-from :xml-constants
*rdf_core_psis.xtm*)
More information about the Isidorus-cvs
mailing list