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
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
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\"/>"
- " <!-- should get the charvalue '' of type xml-string -->"
- " </isi:occurrence>"
- " </rdf:Description>"
-
- " <rdf:Description rdf:nodeID=\"occurrence-2\">"
- " <isi:scope rdf:resource=\"http://scope-2\"/>"
- " <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
Author: lgiessmann
Date: Thu Sep 3 10:57:42 2009
New Revision: 131
Log:
rdf-importer: fixed some problems with importing isidorus-types; added importers and unit tests for isidorus:Association and isidorus:Role
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/isidorus_constructs_tools.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp (original)
+++ trunk/src/constants.lisp Thu Sep 3 10:57:42 2009
@@ -60,7 +60,8 @@
:*tm2rdf-varianttype-property*
:*tm2rdf-occurrencetype-property*
:*tm2rdf-roletype-property*
- :*tm2rdf-associationtype-property*))
+ :*tm2rdf-associationtype-property*
+ :*tm2rdf-player-property*))
(in-package :constants)
@@ -165,3 +166,5 @@
(defparameter *tm2rdf-roletype-property* (concatenate 'string *tm2rdf-ns* "roletype"))
(defparameter *tm2rdf-associationtype-property* (concatenate 'string *tm2rdf-ns* "associationtype"))
+
+(defparameter *tm2rdf-player-property* (concatenate 'string *tm2rdf-ns* "player"))
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 Sep 3 10:57:42 2009
@@ -73,7 +73,8 @@
:test-isidorus-type-p
:test-get-all-isidorus-nodes-by-id
:test-import-isidorus-name
- :test-import-isidorus-occurrence))
+ :test-import-isidorus-occurrence
+ :test-import-isidorus-association))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -3275,7 +3276,8 @@
" <sw:arc rdf:nodeID=\"node-id-4\"/>"
" </rdf:Description>"
" <sw:Node rdf:nodeID=\"node-id-4\" "
- " xml:base=\"http://base/\">"
+ " xml:base=\"http://base/\""
+ " xml:lang=\"de\">"
" <sw:arc>"
" <rdf:Description rdf:nodeID=\"node-id-1\" "
" xml:base=\"suffix\"/>"
@@ -3300,7 +3302,8 @@
(rdf-importer::child-nodes-or-text
(elt (rdf-importer::child-nodes-or-text
root) 4)) 0)) 0)
- :xml-base "http://base/suffix")))
+ :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)))
@@ -3318,9 +3321,10 @@
(is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
"node-id-4" root sw-node)) :elem)
node-id-4))
- (is (string= (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
- "node-id-4" root sw-node)) :xml-base)
- "http://base/"))
+ (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
@@ -3578,6 +3582,136 @@
(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*
@@ -3606,4 +3740,5 @@
(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))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-import-isidorus-occurrence)
+ (it.bese.fiveam:run! 'test-import-isidorus-association))
\ 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 Sep 3 10:57:42 2009
@@ -86,9 +86,19 @@
(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))))
- (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)
+ 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))))
(setf *_n-map* nil))
@@ -104,47 +114,166 @@
(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))
- ;TODO: create associations and roles -> and iterate in import-dom
- ; over those elements
- (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
- elem start-revision :what "subjectIdentifier"))
- (item-identifiers (make-isidorus-identifiers elem start-revision))
- (subject-locators (make-isidorus-identifiers 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))))))
+ (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
@@ -175,11 +304,11 @@
property *tm2rdf-occurrence-type-uri*
:xml-base xml-base))))))
(let ((item-identities
- (remove-if #'null
- (loop for node in nodes
- append (make-isidorus-identifiers
- (getf node :elem) start-revision))))
- (occurrence-type (make-x-type
+ (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))
@@ -228,13 +357,14 @@
property *tm2rdf-name-type-uri*
:xml-base xml-base))))))
(let ((item-identities
- (remove-if #'null
- (loop for node in nodes
- append (make-isidorus-identifiers
- (getf node :elem) start-revision))))
- (name-type (make-x-type nodes tm-id start-revision
- *tm2rdf-nametype-property*
- :document-id document-id))
+ (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)))
@@ -289,11 +419,10 @@
:old-base
(getf name-node :xml-base))))))))
(let ((item-identities
- (remove-if
- #'null
- (loop for node in nodes
- append (make-isidorus-identifiers
- (getf node :elem) start-revision))))
+ (make-isidorus-identifiers
+ (map 'list #'(lambda(x)
+ (getf x :elem))
+ nodes) start-revision))
(variant-scopes
(append
(make-scopes nodes tm-id start-revision
@@ -317,36 +446,57 @@
(defun make-scopes (node-list tm-id start-revision
&key (document-id *document-id*))
"Creates for every found scope a corresponding topic stub."
- (let ((properties
+ (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 (list :elem property
- :xml-base (get-xml-base
- property
- :old-base
- (getf node :xml-base)))))))))
- (let ((scope-uris
- (remove-if #'null
- (map 'list #'(lambda(x)
- (get-ref-of-property (getf x :elem) tm-id
- (getf x :xml-base)))
- properties))))
- (with-tm (start-revision document-id tm-id)
- (map 'list #'(lambda(x)
- (let ((topicid (getf x :topicid))
- (psi (getf x :psi)))
- (make-topic-stub psi nil topicid nil start-revision
- xml-importer::tm
- :document-id document-id)))
- scope-uris)))))
+ 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)
@@ -401,43 +551,72 @@
-(defun make-x-type (node-list tm-id start-revision uri-of-property
- &key (document-id *document-id*))
+(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 ((property
- (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))
- return (let ((content (child-nodes-or-text (getf node :elem)
+ (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 (list
- :elem property
- :xml-base (get-xml-base property
- :old-base
- (getf
- node
- :xml-base))))))))
- (when property
- (let ((type-uri (get-ref-of-property (getf property :elem) tm-id
- (getf property :xml-base))))
- (unless type-uri
- (error "From make-x-type(): type-uri is missing!"))
- (with-tm (start-revision document-id tm-id)
- (make-topic-stub (getf type-uri :psi) nil
- (getf type-uri :topicid) nil start-revision
- xml-importer::tm :document-id document-id))))))
+ 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)))))
(defun import-arc (elem tm-id start-revision
@@ -464,11 +643,11 @@
(parse-properties-of-node elem UUID)
(let ((subject-identifiers
(make-isidorus-identifiers
- elem start-revision :what "subjectIdentifier"))
+ (list elem) start-revision :what "subjectIdentifier"))
(item-identities
- (make-isidorus-identifiers elem start-revision))
+ (make-isidorus-identifiers (list elem) start-revision))
(subject-locators
- (make-isidorus-identifiers elem start-revision
+ (make-isidorus-identifiers (list elem) start-revision
:what "subjectLocator")))
(let ((this
(make-topic-stub
@@ -608,21 +787,24 @@
(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."
+ topic owner-top and the passed types but not isidorus:Topic."
(declare (d:TopicC owner-top))
- (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))
+ (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)))
(defun make-super-classes (owner-top super-classes tm start-revision
@@ -1244,10 +1426,9 @@
:xml-lang xml-lang))))))))
-(defun make-isidorus-identifiers (owner-elem start-revision &key (what "itemIdentity"))
+(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 (dom:element owner-elem))
(declare (string what))
(when (and (string/= what "itemIdentity")
(string/= what "subjectIdentifier")
@@ -1255,32 +1436,42 @@
(error "From make-identifiers(): what must be set to: ~a but is ~a"
(list "itemIdentity" "subjectIdentifiers" "subjectLocator")
what))
- (let ((content (child-nodes-or-text owner-elem :trim t))
- (class-symbol (cond
- ((string= what "itemIdentity")
- 'ItemIdentifierC)
- ((string= what "subjectIdentifier")
- 'PersistentIdC)
- ((string= what "subjectLocator")
- 'SubjectLocatorC))))
- (unless (stringp content)
- (let ((identifiers
- (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 (let ((uri (child-nodes-or-text property :trim t)))
- (make-instance class-symbol
- :uri uri
- :start-revision start-revision))))
- (identifier-attr
- (let ((attr (get-ns-attribute owner-elem what :ns-uri *tm2rdf-ns*)))
- (when attr
- (list (make-instance class-symbol
- :uri attr
- :start-revision start-revision))))))
- (remove-if #'null (append identifiers identifier-attr))))))
\ No newline at end of file
+ (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
Modified: trunk/src/xml/rdf/isidorus_constructs_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/isidorus_constructs_tools.lisp (original)
+++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Thu Sep 3 10:57:42 2009
@@ -226,12 +226,14 @@
(string= x-uri *tm2rdf-associationtype-property*)
(string= x-uri *tm2rdf-occurrencetype-property*)
(string= x-uri *tm2rdf-roletype-property*)
- (string= x-uri *tm2rdf-subjectLocator-property*))))
+ (string= x-uri *tm2rdf-subjectLocator-property*)
+ (string= x-uri *tm2rdf-player-property*))))
content))))
(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri
&key (parent-xml-base nil)
+ (parent-xml-lang nil)
(collected-nodes nil))
"Returns a list of all nodes that own the given nodeID and are of
type type-uri, rdf:Description or when the rdf:parseType is set to
@@ -246,6 +248,7 @@
t)))
(content (child-nodes-or-text current-node :trim t))
(xml-base (get-xml-base current-node :old-base parent-xml-base))
+ (xml-lang (get-xml-lang current-node :old-lang parent-xml-lang))
(nodeID (get-ns-attribute current-node "nodeID"))
(node-uri-p (let ((node-uri
(concatenate-uri (dom:namespace-uri current-node)
@@ -269,7 +272,8 @@
(if (or datatype parseType (stringp content) (not content))
(if (and (string= nodeID node-id) node-uri-p)
(append (list (list :elem current-node
- :xml-base xml-base))
+ :xml-base parent-xml-base
+ :xml-lang parent-xml-lang))
collected-nodes)
collected-nodes)
(if (and (string= nodeID node-id) node-uri-p)
@@ -277,15 +281,19 @@
append (get-all-isidorus-nodes-by-id
node-id item type-uri
:collected-nodes (append
- (list (list :elem current-node
- :xml-base xml-base))
+ (list (list
+ :elem current-node
+ :xml-base parent-xml-base
+ :xml-lang parent-xml-lang))
collected-nodes)
- :parent-xml-base xml-base))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))
(loop for item across content
append (get-all-isidorus-nodes-by-id
node-id item type-uri
:collected-nodes collected-nodes
- :parent-xml-base xml-base)))))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang)))))
:test #'(lambda(x y)
(eql (getf x :elem) (getf y :elem))))))
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Thu Sep 3 10:57:42 2009
@@ -53,7 +53,8 @@
*tm2rdf-varianttype-property*
*tm2rdf-occurrencetype-property*
*tm2rdf-roletype-property*
- *tm2rdf-associationtype-property*)
+ *tm2rdf-associationtype-property*
+ *tm2rdf-player-property*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
1
0
Author: lgiessmann
Date: Wed Sep 2 10:15:46 2009
New Revision: 130
Log:
rdf-importer: added the functionality of importing isidorus:Occurrence nodes; added also some unti tests
Modified:
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/isidorus_constructs_tools.lisp
Modified: trunk/src/unit_tests/rdf_importer_test.lisp
==============================================================================
--- trunk/src/unit_tests/rdf_importer_test.lisp (original)
+++ trunk/src/unit_tests/rdf_importer_test.lisp Wed Sep 2 10:15:46 2009
@@ -72,7 +72,8 @@
:test-get-all-type-psis
:test-isidorus-type-p
:test-get-all-isidorus-nodes-by-id
- :test-import-isidorus-name))
+ :test-import-isidorus-name
+ :test-import-isidorus-occurrence))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -3479,6 +3480,103 @@
*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\"/>"
+ " <!-- should get the charvalue '' of type xml-string -->"
+ " </isi:occurrence>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:nodeID=\"occurrence-2\">"
+ " <isi:scope rdf:resource=\"http://scope-2\"/>"
+ " <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*)))))))
+
(defun run-rdf-importer-tests()
"Runs all defined tests."
@@ -3507,4 +3605,5 @@
(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))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-import-isidorus-name)
+ (it.bese.fiveam:run! 'test-import-isidorus-occurrence))
\ 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 Wed Sep 2 10:15:46 2009
@@ -104,7 +104,8 @@
(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))
- ;TODO: create associaitons and roles
+ ;TODO: create associations and roles -> and iterate in import-dom
+ ; over those elements
(let ((literals (append (get-literals-of-node elem fn-xml-lang)
(get-literals-of-node-content
elem tm-id xml-base fn-xml-lang)))
@@ -126,8 +127,11 @@
:item-identifiers item-identifiers
:subject-locators subject-locators)))
(make-isidorus-names elem this tm-id start-revision
- :owner-xml-base fn-xml-base)
- ;TODO: create topic occurrences
+ :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
@@ -143,17 +147,70 @@
this))))))
+(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
+ (remove-if #'null
+ (loop for node in nodes
+ append (make-isidorus-identifiers
+ (getf node :elem) start-revision))))
+ (occurrence-type (make-x-type
+ 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 a resource node that are in a property isidorus:name
+ "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)))
+ (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
@@ -163,7 +220,7 @@
(let ((xml-base (get-xml-base property
:old-base owner-xml-base)))
(let ((nodes
- (let ((nodeID (get-ns-attribute property "nodeID")))
+ (let ((nodeID (nodeID-of-property-or-child property)))
(if nodeID
(get-all-isidorus-nodes-by-id
nodeID root *tm2rdf-name-type-uri*)
@@ -175,11 +232,15 @@
(loop for node in nodes
append (make-isidorus-identifiers
(getf node :elem) start-revision))))
- (name-type (make-name-type nodes tm-id start-revision
- :document-id document-id))
+ (name-type (make-x-type 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
@@ -200,7 +261,8 @@
(let ((root
(when name-nodes
(elt (dom:child-nodes
- (dom:owner-document (getf (first name-nodes) :elem))) 0))))
+ (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
@@ -237,7 +299,10 @@
(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)))
+ (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
@@ -336,7 +401,7 @@
-(defun make-name-type (node-list tm-id start-revision
+(defun make-x-type (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."
@@ -348,7 +413,7 @@
when (let ((prop-ns (dom:namespace-uri property))
(prop-name (get-node-name property)))
(string= (concatenate-uri prop-ns prop-name)
- *tm2rdf-nametype-property*))
+ uri-of-property))
return property))
return (let ((content (child-nodes-or-text (getf node :elem)
:trim t)))
@@ -356,7 +421,7 @@
when (let ((prop-ns (dom:namespace-uri property))
(prop-name (get-node-name property)))
(string= (concatenate-uri prop-ns prop-name)
- *tm2rdf-nametype-property*))
+ uri-of-property))
return (list
:elem property
:xml-base (get-xml-base property
@@ -368,7 +433,7 @@
(let ((type-uri (get-ref-of-property (getf property :elem) tm-id
(getf property :xml-base))))
(unless type-uri
- (error "From make-name-type(): type-uri is missing!"))
+ (error "From make-x-type(): type-uri is missing!"))
(with-tm (start-revision document-id tm-id)
(make-topic-stub (getf type-uri :psi) nil
(getf type-uri :topicid) nil start-revision
@@ -430,7 +495,9 @@
(make-isidorus-names elem this tm-id start-revision
:owner-xml-base xml-base
:document-id document-id)
- ;TDOD: create topic occurrences
+ (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
Modified: trunk/src/xml/rdf/isidorus_constructs_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/isidorus_constructs_tools.lisp (original)
+++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Wed Sep 2 10:15:46 2009
@@ -317,4 +317,19 @@
(list :elem (elt content 0)
:xml-base (get-xml-base (elt content 0) :old-base xml-base))
(list :elem property-node
- :xml-base xml-base))))
\ No newline at end of file
+ :xml-base xml-base))))
+
+
+(defun nodeID-of-property-or-child (elem)
+ "Returns either the nodeID of the given element or if tere isn't one
+ the nodeID of the element's first child node. If there is no nodeID
+ at all, nil is returned."
+ (declare (dom:element elem))
+ (let ((elem-nodeID (get-ns-attribute elem "nodeID")))
+ (if elem-nodeID
+ elem-nodeID
+ (let ((elem-content (child-nodes-or-text elem :trim t)))
+ (when (and (> (length elem-content) 0)
+ (not (stringp elem-content)))
+ (get-ns-attribute (elt elem-content 0) "nodeID"))))))
+
\ No newline at end of file
1
0
Author: lgiessmann
Date: Wed Sep 2 08:56:17 2009
New Revision: 129
Log:
rdf-importer: cleaned some code passages of the rdf module.
Added:
trunk/src/xml/rdf/isidorus_constructs_tools.lisp
Modified:
trunk/src/isidorus.asd
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Wed Sep 2 08:56:17 2009
@@ -53,8 +53,10 @@
"exporter_xtm2.0"))))
(:module "rdf"
:components ((:file "rdf_tools")
- (:file "importer"
+ (:file "isidorus_constructs_tools"
:depends-on ("rdf_tools"))
+ (:file "importer"
+ :depends-on ("rdf_tools" "isidorus_constructs_tools"))
(:file "exporter"))
:depends-on ("xtm")))
:depends-on ("constants"
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Wed Sep 2 08:56:17 2009
@@ -180,8 +180,6 @@
(name-value (getf (make-value nodes tm-id) :value))
(name-scopes (make-scopes nodes tm-id start-revision
:document-id document-id)))
- ;(format t "ii: ~a~%type: ~a~%value: ~a~%scopes: ~a~%~%"
- ; item-identities name-type name-value name-scopes)
(let ((this
(make-construct 'NameC
:start-revision start-revision
@@ -248,25 +246,8 @@
(getf value-and-type :value)
:datatype
(getf value-and-type :datatype)
- :name owner-name))))))))))
-
+ :name owner-name))))))))))
-(defun self-or-child-node (property-node type-uri &key (xml-base))
- "Returns either the passed node or the child-node when it is
- rdf:Description."
- (declare (dom:element property-node))
- (let ((content (child-nodes-or-text property-node :trim t)))
- (if (and (= (length content) 1)
- (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*)
- (string= (get-node-name (elt content 0)) "Description"))
- (string= (concatenate-uri (dom:namespace-uri (elt content 0))
- (get-node-name (elt content 0)))
- type-uri)))
- (list :elem (elt content 0)
- :xml-base (get-xml-base (elt content 0) :old-base xml-base))
- (list :elem property-node
- :xml-base xml-base))))
-
(defun make-scopes (node-list tm-id start-revision
&key (document-id *document-id*))
Added: trunk/src/xml/rdf/isidorus_constructs_tools.lisp
==============================================================================
--- (empty file)
+++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Wed Sep 2 08:56:17 2009
@@ -0,0 +1,320 @@
+;;+-----------------------------------------------------------------------------
+;;+ 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 get-type-psis (elem tm-id
+ &key (parent-xml-base nil))
+ "Returns a list of type-uris of the passed node."
+ (let ((types (get-types-of-node elem tm-id
+ :parent-xml-base parent-xml-base)))
+ (remove-if #'null
+ (map 'list #'(lambda(x)
+ (getf x :psi))
+ types))))
+
+
+(defun get-all-type-psis-of-id (nodeID tm-id document)
+ "Returns a list of type-uris for resources identified by the given
+ nodeID by analysing the complete XML-DOM."
+ (let ((root (elt (dom:child-nodes document) 0)))
+ (remove-duplicates
+ (remove-if #'null
+ (if (and (string= (dom:namespace-uri root) *rdf-ns*)
+ (string= (get-node-name root)"RDF"))
+ (loop for node across (child-nodes-or-text root)
+ append (get-all-type-psis-across-dom
+ root tm-id :resource-id nodeID))
+ (get-all-type-psis-across-dom
+ root tm-id :resource-id nodeID)))
+ :test #'string=)))
+
+
+(defun get-all-type-psis (elem tm-id &key (parent-xml-base nil))
+ "Returns a list of type-uris for the element by analysing the complete
+ XML-DOM."
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+ (let ((root (elt (dom:child-nodes (dom:owner-document elem)) 0))
+ (nodeID (get-ns-attribute elem "nodeID"))
+ (about (get-absolute-attribute elem tm-id xml-base "about")))
+ (remove-duplicates
+ (remove-if #'null
+ (if (or nodeID about)
+ (if (and (string= (dom:namespace-uri root) *rdf-ns*)
+ (string= (get-node-name root) "RDF"))
+ (loop for node across (child-nodes-or-text root)
+ append (get-all-type-psis-across-dom
+ root tm-id :resource-uri about
+ :resource-id nodeID))
+ (get-all-type-psis-across-dom
+ root tm-id :resource-uri about
+ :resource-id nodeID))
+ (get-type-psis elem tm-id :parent-xml-base parent-xml-base)))
+ :test #'string=))))
+
+
+(defun get-all-type-psis-across-dom (elem tm-id &key (parent-xml-base nil)
+ (resource-uri nil) (resource-id nil)
+ (types nil))
+ "Returns a list of type PSI strings collected over the complete XML-DOM
+ corresponding to the passed id's or uri."
+ (when (or resource-uri resource-id)
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+ (let ((datatype (when (get-ns-attribute elem "datatype")
+ t))
+ (parseType (when (get-ns-attribute elem "parseType")
+ (string= (get-ns-attribute elem "parseType")
+ "Literal"))))
+ (if (or datatype parseType)
+ types
+ (let ((nodeID (get-ns-attribute elem "nodeID"))
+ (about (get-absolute-attribute elem tm-id xml-base "about")))
+ (let ((fn-types
+ (append types
+ (when (or (and about resource-uri
+ (string= about resource-uri))
+ (and nodeID resource-id
+ (string= nodeID resource-id)))
+ (get-type-psis elem tm-id
+ :parent-xml-base xml-base))))
+ (content (child-nodes-or-text elem :trim t)))
+ (if (or (stringp content)
+ (not content))
+ fn-types
+ (loop for child-node across content
+ append (get-all-type-psis-across-dom
+ child-node tm-id :parent-xml-base xml-base
+ :resource-uri resource-uri
+ :resource-id resource-id
+ :types fn-types))))))))))
+
+
+(defun type-p (elem type-uri tm-id &key (parent-xml-base nil))
+ "Returns t if the type-uri is a type of elem."
+ (declare (string tm-id type-uri))
+ (declare (dom:element elem))
+ (tm-id-p tm-id "type-p")
+ (find type-uri (get-all-type-psis elem tm-id
+ :parent-xml-base parent-xml-base)
+ :test #'string=))
+
+
+(defun type-of-id-p (node-id type-uri tm-id document)
+ "Returns t if type-uri is a type of the passed node-id."
+ (declare (string node-id type-uri tm-id))
+ (declare (dom:document document))
+ (tm-id-p tm-id "type-of-ndoe-id-p")
+ (find type-uri (get-all-type-psis-of-id node-id tm-id document)
+ :test #'string=))
+
+
+(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil)
+ (ignore-topic nil))
+ "Returns t if the passed element is not of an isidorus' type.
+ The environmental property is not analysed by this function!"
+ (declare (dom:element elem))
+ (declare (string tm-id))
+ (let ((nodeID (get-ns-attribute elem "nodeID"))
+ (document (dom:owner-document elem))
+ (types
+ (let ((b-types
+ (list
+ *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri*
+ *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri*
+ *tm2rdf-role-type-uri*))
+ (a-types (list *tm2rdf-topic-type-uri*)))
+ (if ignore-topic
+ b-types
+ (append a-types b-types)))))
+ (if nodeID
+ (not (loop for type in types
+ when (type-of-id-p nodeId type tm-id document)
+ return t))
+ (not (loop for type in types
+ when (type-p elem type tm-id
+ :parent-xml-base parent-xml-base)
+ return t)))))
+
+
+(defun isidorus-type-p (property-elem-or-node-elem tm-id what
+ &key(parent-xml-base nil))
+ "Returns t if the node elem is of the type isidorus:<Type> and is
+ contained in a porperty isidorus:<type>."
+ (declare (dom:element property-elem-or-node-elem))
+ (declare (symbol what))
+ (tm-id-p tm-id "isidorus-type-p")
+ (let ((xml-base (get-xml-base property-elem-or-node-elem
+ :old-base parent-xml-base))
+ (type-and-property (cond
+ ((eql what 'name)
+ (list :type *tm2rdf-name-type-uri*
+ :property *tm2rdf-name-property*))
+ ((eql what 'variant)
+ (list :type *tm2rdf-variant-type-uri*
+ :property *tm2rdf-variant-property*))
+ ((eql what 'occurrence)
+ (list :type *tm2rdf-occurrence-type-uri*
+ :property *tm2rdf-occurrence-property*))
+ ((eql what 'role)
+ (list :type *tm2rdf-role-type-uri*
+ :property *tm2rdf-role-property*))
+ ((eql what 'topic)
+ (list :type *tm2rdf-topic-type-uri*))
+ ((eql what 'association)
+ (list :type
+ *tm2rdf-association-type-uri*)))))
+ (when type-and-property
+ (let ((type (getf type-and-property :type))
+ (property (getf type-and-property :property))
+ (nodeID (get-ns-attribute property-elem-or-node-elem "nodeID"))
+ (document (dom:owner-document property-elem-or-node-elem))
+ (elem-uri (concatenate-uri
+ (dom:namespace-uri
+ property-elem-or-node-elem)
+ (get-node-name property-elem-or-node-elem))))
+ (if (or (string= type *tm2rdf-topic-type-uri*)
+ (string= type *tm2rdf-association-type-uri*)
+ (let ((parseType (get-ns-attribute property-elem-or-node-elem
+ "parseType")))
+ (and parseType
+ (string= parseType "Resource")))
+ (get-ns-attribute property-elem-or-node-elem "type")
+ (get-ns-attribute property-elem-or-node-elem "value"
+ :ns-uri *tm2rdf-ns*)
+ (get-ns-attribute property-elem-or-node-elem "itemIdentity"
+ :ns-uri *tm2rdf-ns*))
+ (type-p property-elem-or-node-elem type tm-id
+ :parent-xml-base parent-xml-base)
+ (when (string= elem-uri property)
+ (if nodeID
+ (type-of-id-p nodeId type tm-id document)
+ (let ((content (child-nodes-or-text property-elem-or-node-elem
+ :trim t)))
+ (when (and (= (length content) 1)
+ (not (stringp content)))
+ (type-p (elt content 0) type tm-id
+ :parent-xml-base xml-base))))))))))
+
+
+(defun non-isidorus-child-nodes-or-text (elem &key (trim nil))
+ "Returns a list of node elements that are no isidorus properties, e.g.
+ isidorus:name, string-content or nil."
+ (let ((content (child-nodes-or-text elem :trim trim)))
+ (if (or (not content)
+ (stringp content))
+ content
+ (remove-if #'(lambda(x)
+ (let ((x-uri (if (dom:namespace-uri x)
+ (concatenate-uri (dom:namespace-uri x)
+ (get-node-name x))
+ (get-node-name x))))
+ (or (string= x-uri *tm2rdf-name-property*)
+ (string= x-uri *tm2rdf-variant-property*)
+ (string= x-uri *tm2rdf-occurrence-property*)
+ (string= x-uri *tm2rdf-role-property*)
+ (string= x-uri *tm2rdf-subjectIdentifier-property*)
+ (string= x-uri *tm2rdf-itemIdentity-property*)
+ (string= x-uri *tm2rdf-value-property*)
+ (string= x-uri *tm2rdf-scope-property*)
+ (string= x-uri *tm2rdf-nametype-property*)
+ (string= x-uri *tm2rdf-varianttype-property*)
+ (string= x-uri *tm2rdf-associationtype-property*)
+ (string= x-uri *tm2rdf-occurrencetype-property*)
+ (string= x-uri *tm2rdf-roletype-property*)
+ (string= x-uri *tm2rdf-subjectLocator-property*))))
+ content))))
+
+
+(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri
+ &key (parent-xml-base nil)
+ (collected-nodes nil))
+ "Returns a list of all nodes that own the given nodeID and are of
+ type type-uri, rdf:Description or when the rdf:parseType is set to
+ Resource or the isidorus:value attribute is set."
+ (declare (dom:element current-node))
+ (declare (string node-id))
+ (let ((datatype (when (get-ns-attribute current-node "datatype")
+ t))
+ (parseType (let ((attr (get-ns-attribute current-node "parseType")))
+ (when (and attr
+ (string= attr "Literal"))
+ t)))
+ (content (child-nodes-or-text current-node :trim t))
+ (xml-base (get-xml-base current-node :old-base parent-xml-base))
+ (nodeID (get-ns-attribute current-node "nodeID"))
+ (node-uri-p (let ((node-uri
+ (concatenate-uri (dom:namespace-uri current-node)
+ (get-node-name current-node)))
+ (description (concatenate 'string *rdf-ns*
+ "Description")))
+ (or (string= node-uri (if type-uri type-uri ""))
+ (string= node-uri description)
+ (get-ns-attribute current-node "type")
+ (get-ns-attribute current-node "value"
+ :ns-uri *tm2rdf-ns*)
+ (get-ns-attribute current-node "itemIdentity"
+ :ns-uri *tm2rdf-ns*)
+ (let ((parseType (get-ns-attribute current-node
+ "parseType")))
+ (when parseType
+ (string= parseType "Resource")))))))
+ (remove-duplicates
+ (remove-if
+ #'null
+ (if (or datatype parseType (stringp content) (not content))
+ (if (and (string= nodeID node-id) node-uri-p)
+ (append (list (list :elem current-node
+ :xml-base xml-base))
+ collected-nodes)
+ collected-nodes)
+ (if (and (string= nodeID node-id) node-uri-p)
+ (loop for item across content
+ append (get-all-isidorus-nodes-by-id
+ node-id item type-uri
+ :collected-nodes (append
+ (list (list :elem current-node
+ :xml-base xml-base))
+ collected-nodes)
+ :parent-xml-base xml-base))
+ (loop for item across content
+ append (get-all-isidorus-nodes-by-id
+ node-id item type-uri
+ :collected-nodes collected-nodes
+ :parent-xml-base xml-base)))))
+ :test #'(lambda(x y)
+ (eql (getf x :elem) (getf y :elem))))))
+
+
+(defun filter-isidorus-literals (literals)
+ "Removes all literals that are known isidorus properties which
+ are able to contain literal data."
+ (remove-if #'(lambda(x)
+ (or (string= (getf x :type)
+ *tm2rdf-subjectIdentifier-property*)
+ (string= (getf x :type)
+ *tm2rdf-itemIdentity-property*)
+ (string= (getf x :type)
+ *tm2rdf-subjectLocator-property*)))
+ literals))
+
+
+(defun self-or-child-node (property-node type-uri &key (xml-base))
+ "Returns either the passed node or the child-node when it is
+ rdf:Description."
+ (declare (dom:element property-node))
+ (let ((content (child-nodes-or-text property-node :trim t)))
+ (if (and (= (length content) 1)
+ (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*)
+ (string= (get-node-name (elt content 0)) "Description"))
+ (string= (concatenate-uri (dom:namespace-uri (elt content 0))
+ (get-node-name (elt content 0)))
+ type-uri)))
+ (list :elem (elt content 0)
+ :xml-base (get-xml-base (elt content 0) :old-base xml-base))
+ (list :elem property-node
+ :xml-base xml-base))))
\ 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 2 08:56:17 2009
@@ -545,307 +545,3 @@
:psi (get-ns-attribute elem "type")))))))
-(defun get-type-psis (elem tm-id
- &key (parent-xml-base nil))
- "Returns a list of type-uris of the passed node."
- (let ((types (get-types-of-node elem tm-id
- :parent-xml-base parent-xml-base)))
- (remove-if #'null
- (map 'list #'(lambda(x)
- (getf x :psi))
- types))))
-
-
-(defun get-all-type-psis-of-id (nodeID tm-id document)
- "Returns a list of type-uris for resources identified by the given
- nodeID by analysing the complete XML-DOM."
- (let ((root (elt (dom:child-nodes document) 0)))
- (remove-duplicates
- (remove-if #'null
- (if (and (string= (dom:namespace-uri root) *rdf-ns*)
- (string= (get-node-name root)"RDF"))
- (loop for node across (child-nodes-or-text root)
- append (get-all-type-psis-across-dom
- root tm-id :resource-id nodeID))
- (get-all-type-psis-across-dom
- root tm-id :resource-id nodeID)))
- :test #'string=)))
-
-
-(defun get-all-type-psis (elem tm-id &key (parent-xml-base nil))
- "Returns a list of type-uris for the element by analysing the complete
- XML-DOM."
- (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
- (let ((root (elt (dom:child-nodes (dom:owner-document elem)) 0))
- (nodeID (get-ns-attribute elem "nodeID"))
- (about (get-absolute-attribute elem tm-id xml-base "about")))
- (remove-duplicates
- (remove-if #'null
- (if (or nodeID about)
- (if (and (string= (dom:namespace-uri root) *rdf-ns*)
- (string= (get-node-name root) "RDF"))
- (loop for node across (child-nodes-or-text root)
- append (get-all-type-psis-across-dom
- root tm-id :resource-uri about
- :resource-id nodeID))
- (get-all-type-psis-across-dom
- root tm-id :resource-uri about
- :resource-id nodeID))
- (get-type-psis elem tm-id :parent-xml-base parent-xml-base)))
- :test #'string=))))
-
-
-(defun get-all-type-psis-across-dom (elem tm-id &key (parent-xml-base nil)
- (resource-uri nil) (resource-id nil)
- (types nil))
- "Returns a list of type PSI strings collected over the complete XML-DOM
- corresponding to the passed id's or uri."
- (when (or resource-uri resource-id)
- (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
- (let ((datatype (when (get-ns-attribute elem "datatype")
- t))
- (parseType (when (get-ns-attribute elem "parseType")
- (string= (get-ns-attribute elem "parseType")
- "Literal"))))
- (if (or datatype parseType)
- types
- (let ((nodeID (get-ns-attribute elem "nodeID"))
- (about (get-absolute-attribute elem tm-id xml-base "about")))
- (let ((fn-types
- (append types
- (when (or (and about resource-uri
- (string= about resource-uri))
- (and nodeID resource-id
- (string= nodeID resource-id)))
- (get-type-psis elem tm-id
- :parent-xml-base xml-base))))
- (content (child-nodes-or-text elem :trim t)))
- (if (or (stringp content)
- (not content))
- fn-types
- (loop for child-node across content
- append (get-all-type-psis-across-dom
- child-node tm-id :parent-xml-base xml-base
- :resource-uri resource-uri
- :resource-id resource-id
- :types fn-types))))))))))
-
-
-(defun type-p (elem type-uri tm-id &key (parent-xml-base nil))
- "Returns t if the type-uri is a type of elem."
- (declare (string tm-id type-uri))
- (declare (dom:element elem))
- (tm-id-p tm-id "type-p")
- (find type-uri (get-all-type-psis elem tm-id
- :parent-xml-base parent-xml-base)
- :test #'string=))
-
-
-(defun type-of-id-p (node-id type-uri tm-id document)
- "Returns t if type-uri is a type of the passed node-id."
- (declare (string node-id type-uri tm-id))
- (declare (dom:document document))
- (tm-id-p tm-id "type-of-ndoe-id-p")
- (find type-uri (get-all-type-psis-of-id node-id tm-id document)
- :test #'string=))
-
-
-(defun property-name-of-node-p (elem property-name-uri)
- "Returns t if the elements tag-name and namespace are equal
- to the given uri."
- (declare (dom:element elem))
- (declare (string property-name-uri))
- (when property-name-uri
- (let ((uri (concatenate-uri (dom:namespace-uri elem)
- (get-node-name elem))))
- (string= uri property-name-uri))))
-
-
-(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil)
- (ignore-topic nil))
- "Returns t if the passed element is not of an isidorus' type.
- The environmental property is not analysed by this function!"
- (declare (dom:element elem))
- (declare (string tm-id))
- (let ((nodeID (get-ns-attribute elem "nodeID"))
- (document (dom:owner-document elem))
- (types
- (let ((b-types
- (list
- *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri*
- *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri*
- *tm2rdf-role-type-uri*))
- (a-types (list *tm2rdf-topic-type-uri*)))
- (if ignore-topic
- b-types
- (append a-types b-types)))))
- (if nodeID
- (not (loop for type in types
- when (type-of-id-p nodeId type tm-id document)
- return t))
- (not (loop for type in types
- when (type-p elem type tm-id
- :parent-xml-base parent-xml-base)
- return t)))))
-
-
-(defun isidorus-type-p (property-elem-or-node-elem tm-id what
- &key(parent-xml-base nil))
- "Returns t if the node elem is of the type isidorus:<Type> and is
- contained in a porperty isidorus:<type>."
- (declare (dom:element property-elem-or-node-elem))
- (declare (symbol what))
- (tm-id-p tm-id "isidorus-type-p")
- (let ((xml-base (get-xml-base property-elem-or-node-elem
- :old-base parent-xml-base))
- (type-and-property (cond
- ((eql what 'name)
- (list :type *tm2rdf-name-type-uri*
- :property *tm2rdf-name-property*))
- ((eql what 'variant)
- (list :type *tm2rdf-variant-type-uri*
- :property *tm2rdf-variant-property*))
- ((eql what 'occurrence)
- (list :type *tm2rdf-occurrence-type-uri*
- :property *tm2rdf-occurrence-property*))
- ((eql what 'role)
- (list :type *tm2rdf-role-type-uri*
- :property *tm2rdf-role-property*))
- ((eql what 'topic)
- (list :type *tm2rdf-topic-type-uri*))
- ((eql what 'association)
- (list :type
- *tm2rdf-association-type-uri*)))))
- (when type-and-property
- (let ((type (getf type-and-property :type))
- (property (getf type-and-property :property))
- (nodeID (get-ns-attribute property-elem-or-node-elem "nodeID"))
- (document (dom:owner-document property-elem-or-node-elem))
- (elem-uri (concatenate-uri
- (dom:namespace-uri
- property-elem-or-node-elem)
- (get-node-name property-elem-or-node-elem))))
- (if (or (string= type *tm2rdf-topic-type-uri*)
- (string= type *tm2rdf-association-type-uri*)
- (let ((parseType (get-ns-attribute property-elem-or-node-elem
- "parseType")))
- (and parseType
- (string= parseType "Resource")))
- (get-ns-attribute property-elem-or-node-elem "type")
- (get-ns-attribute property-elem-or-node-elem "value"
- :ns-uri *tm2rdf-ns*)
- (get-ns-attribute property-elem-or-node-elem "itemIdentity"
- :ns-uri *tm2rdf-ns*))
- (type-p property-elem-or-node-elem type tm-id
- :parent-xml-base parent-xml-base)
- (when (string= elem-uri property)
- (if nodeID
- (type-of-id-p nodeId type tm-id document)
- (let ((content (child-nodes-or-text property-elem-or-node-elem
- :trim t)))
- (when (and (= (length content) 1)
- (not (stringp content)))
- (type-p (elt content 0) type tm-id
- :parent-xml-base xml-base))))))))))
-
-
-(defun non-isidorus-child-nodes-or-text (elem &key (trim nil))
- "Returns a list of node elements that are no isidorus properties, e.g.
- isidorus:name, string-content or nil."
- (let ((content (child-nodes-or-text elem :trim trim)))
- (if (or (not content)
- (stringp content))
- content
- (remove-if #'(lambda(x)
- (let ((x-uri (if (dom:namespace-uri x)
- (concatenate-uri (dom:namespace-uri x)
- (get-node-name x))
- (get-node-name x))))
- (or (string= x-uri *tm2rdf-name-property*)
- (string= x-uri *tm2rdf-variant-property*)
- (string= x-uri *tm2rdf-occurrence-property*)
- (string= x-uri *tm2rdf-role-property*)
- (string= x-uri *tm2rdf-subjectIdentifier-property*)
- (string= x-uri *tm2rdf-itemIdentity-property*)
- (string= x-uri *tm2rdf-value-property*)
- (string= x-uri *tm2rdf-scope-property*)
- (string= x-uri *tm2rdf-nametype-property*)
- (string= x-uri *tm2rdf-varianttype-property*)
- (string= x-uri *tm2rdf-associationtype-property*)
- (string= x-uri *tm2rdf-occurrencetype-property*)
- (string= x-uri *tm2rdf-roletype-property*)
- (string= x-uri *tm2rdf-subjectLocator-property*))))
- content))))
-
-
-(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri
- &key (parent-xml-base nil)
- (collected-nodes nil))
- "Returns a list of all nodes that own the given nodeID and are of
- type type-uri, rdf:Description or when the rdf:parseType is set to
- Resource or the isidorus:value attribute is set."
- (declare (dom:element current-node))
- (declare (string node-id))
- (let ((datatype (when (get-ns-attribute current-node "datatype")
- t))
- (parseType (let ((attr (get-ns-attribute current-node "parseType")))
- (when (and attr
- (string= attr "Literal"))
- t)))
- (content (child-nodes-or-text current-node :trim t))
- (xml-base (get-xml-base current-node :old-base parent-xml-base))
- (nodeID (get-ns-attribute current-node "nodeID"))
- (node-uri-p (let ((node-uri
- (concatenate-uri (dom:namespace-uri current-node)
- (get-node-name current-node)))
- (description (concatenate 'string *rdf-ns*
- "Description")))
- (or (string= node-uri (if type-uri type-uri ""))
- (string= node-uri description)
- (get-ns-attribute current-node "type")
- (get-ns-attribute current-node "value"
- :ns-uri *tm2rdf-ns*)
- (get-ns-attribute current-node "itemIdentity"
- :ns-uri *tm2rdf-ns*)
- (let ((parseType (get-ns-attribute current-node
- "parseType")))
- (when parseType
- (string= parseType "Resource")))))))
- (remove-duplicates
- (remove-if
- #'null
- (if (or datatype parseType (stringp content) (not content))
- (if (and (string= nodeID node-id) node-uri-p)
- (append (list (list :elem current-node
- :xml-base xml-base))
- collected-nodes)
- collected-nodes)
- (if (and (string= nodeID node-id) node-uri-p)
- (loop for item across content
- append (get-all-isidorus-nodes-by-id
- node-id item type-uri
- :collected-nodes (append
- (list (list :elem current-node
- :xml-base xml-base))
- collected-nodes)
- :parent-xml-base xml-base))
- (loop for item across content
- append (get-all-isidorus-nodes-by-id
- node-id item type-uri
- :collected-nodes collected-nodes
- :parent-xml-base xml-base)))))
- :test #'(lambda(x y)
- (eql (getf x :elem) (getf y :elem))))))
-
-
-(defun filter-isidorus-literals (literals)
- "Removes all literals that are known isidorus properties which
- are able to contain literal data."
- (remove-if #'(lambda(x)
- (or (string= (getf x :type)
- *tm2rdf-subjectIdentifier-property*)
- (string= (getf x :type)
- *tm2rdf-itemIdentity-property*)
- (string= (getf x :type)
- *tm2rdf-subjectLocator-property*)))
- literals))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Wed Sep 2 06:58:33 2009
New Revision: 128
Log:
rdf-importer: added handling for the isidorus-types Topic, Name and Variant; currently importing isidorus:Association and isidorus:Role is missing
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/rdf_importer_test.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 Wed Sep 2 06:58:33 2009
@@ -53,7 +53,14 @@
:*tm2rdf-associaiton-property*
:*tm2rdf-subjectIdentifier-property*
:*tm2rdf-itemIdentity-property*
- :*tm2rdf-subjectLocator-property*))
+ :*tm2rdf-subjectLocator-property*
+ :*tm2rdf-value-property*
+ :*tm2rdf-nametype-property*
+ :*tm2rdf-scope-property*
+ :*tm2rdf-varianttype-property*
+ :*tm2rdf-occurrencetype-property*
+ :*tm2rdf-roletype-property*
+ :*tm2rdf-associationtype-property*))
(in-package :constants)
@@ -144,3 +151,17 @@
(defparameter *tm2rdf-subjectLocator-property* (concatenate 'string *tm2rdf-ns* "subjectLocator"))
(defparameter *tm2rdf-itemIdentity-property* (concatenate 'string *tm2rdf-ns* "itemIdentity"))
+
+(defparameter *tm2rdf-value-property* (concatenate 'string *tm2rdf-ns* "value"))
+
+(defparameter *tm2rdf-nametype-property* (concatenate 'string *tm2rdf-ns* "nametype"))
+
+(defparameter *tm2rdf-scope-property* (concatenate 'string *tm2rdf-ns* "scope"))
+
+(defparameter *tm2rdf-varianttype-property* (concatenate 'string *tm2rdf-ns* "varianttype"))
+
+(defparameter *tm2rdf-occurrencetype-property* (concatenate 'string *tm2rdf-ns* "occurrencetype"))
+
+(defparameter *tm2rdf-roletype-property* (concatenate 'string *tm2rdf-ns* "roletype"))
+
+(defparameter *tm2rdf-associationtype-property* (concatenate 'string *tm2rdf-ns* "associationtype"))
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 Wed Sep 2 06:58:33 2009
@@ -21,6 +21,7 @@
*tm2rdf-ns*
*xml-ns*
*xml-string*
+ *xml-uri*
*instance-psi*
*type-psi*
*type-instance-psi*
@@ -69,7 +70,9 @@
:test-xml-base
:test-get-type-psis
:test-get-all-type-psis
- :test-isidorus-type-p))
+ :test-isidorus-type-p
+ :test-get-all-isidorus-nodes-by-id
+ :test-import-isidorus-name))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -3256,6 +3259,227 @@
'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/\">"
+ " <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/suffix")))
+ (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 (string= (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-4" root sw-node)) :xml-base)
+ "http://base/"))
+ (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*))))))))
+
+
+
(defun run-rdf-importer-tests()
"Runs all defined tests."
(when elephant:*store-controller*
@@ -3281,4 +3505,6 @@
(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))
\ No newline at end of file
+ (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))
\ 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 Wed Sep 2 06:58:33 2009
@@ -84,6 +84,7 @@
(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))))
(import-node rdf-dom tm-id start-revision :document-id document-id
@@ -96,31 +97,37 @@
(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)))
+ (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
+ (fn-xml-base (get-xml-base elem :old-base xml-base)))
(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))
-
+ ;TODO: create associaitons and roles
(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)))
- ;TODO: collect isidorus' subjectIdentifiers, itemIdentities,
- ; subjectLocators, names and occurrences
- ; add the collected constructs to the topic-stub
-
- ;TODO: collect associations and association roles and create the
- ; corresponding constructs and stops the recusrion
+ (get-super-classes-of-node-content elem tm-id xml-base))
+ (subject-identities (make-isidorus-identifiers
+ elem start-revision :what "subjectIdentifier"))
+ (item-identifiers (make-isidorus-identifiers elem start-revision))
+ (subject-locators (make-isidorus-identifiers 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)))
+ :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)
+ ;TODO: create topic occurrences
(make-literals this literals tm-id start-revision
:document-id document-id)
(make-associations this associations xml-importer::tm
@@ -136,6 +143,257 @@
this))))))
+
+(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 a resource node 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)))
+ (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 (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-name-type-uri*
+ :xml-base xml-base))))))
+ (let ((item-identities
+ (remove-if #'null
+ (loop for node in nodes
+ append (make-isidorus-identifiers
+ (getf node :elem) start-revision))))
+ (name-type (make-name-type nodes tm-id start-revision
+ :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)))
+ ;(format t "ii: ~a~%type: ~a~%value: ~a~%scopes: ~a~%~%"
+ ; item-identities name-type name-value name-scopes)
+ (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))))
+ (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
+ (remove-if
+ #'null
+ (loop for node in nodes
+ append (make-isidorus-identifiers
+ (getf node :elem) 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)))
+ (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 self-or-child-node (property-node type-uri &key (xml-base))
+ "Returns either the passed node or the child-node when it is
+ rdf:Description."
+ (declare (dom:element property-node))
+ (let ((content (child-nodes-or-text property-node :trim t)))
+ (if (and (= (length content) 1)
+ (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*)
+ (string= (get-node-name (elt content 0)) "Description"))
+ (string= (concatenate-uri (dom:namespace-uri (elt content 0))
+ (get-node-name (elt content 0)))
+ type-uri)))
+ (list :elem (elt content 0)
+ :xml-base (get-xml-base (elt content 0) :old-base xml-base))
+ (list :elem property-node
+ :xml-base xml-base))))
+
+
+(defun make-scopes (node-list tm-id start-revision
+ &key (document-id *document-id*))
+ "Creates for every found scope a corresponding topic stub."
+ (let ((properties
+ (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 (list :elem property
+ :xml-base (get-xml-base
+ property
+ :old-base
+ (getf node :xml-base)))))))))
+ (let ((scope-uris
+ (remove-if #'null
+ (map 'list #'(lambda(x)
+ (get-ref-of-property (getf x :elem) tm-id
+ (getf x :xml-base)))
+ properties))))
+ (with-tm (start-revision document-id tm-id)
+ (map 'list #'(lambda(x)
+ (let ((topicid (getf x :topicid))
+ (psi (getf x :psi)))
+ (make-topic-stub psi nil topicid nil start-revision
+ xml-importer::tm
+ :document-id document-id)))
+ scope-uris)))))
+
+
+(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 make-name-type (node-list tm-id start-revision
+ &key (document-id *document-id*))
+ "Creates a topic stub that is the type of the name represented by the
+ passed nodes."
+ (let ((property
+ (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)
+ *tm2rdf-nametype-property*))
+ return property))
+ return (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-nametype-property*))
+ return (list
+ :elem property
+ :xml-base (get-xml-base property
+ :old-base
+ (getf
+ node
+ :xml-base))))))))
+ (when property
+ (let ((type-uri (get-ref-of-property (getf property :elem) tm-id
+ (getf property :xml-base))))
+ (unless type-uri
+ (error "From make-name-type(): type-uri is missing!"))
+ (with-tm (start-revision document-id tm-id)
+ (make-topic-stub (getf type-uri :psi) nil
+ (getf type-uri :topicid) nil start-revision
+ xml-importer::tm :document-id document-id))))))
+
+
(defun import-arc (elem tm-id start-revision
&key (document-id *document-id*)
(xml-base nil) (xml-lang nil))
@@ -144,7 +402,6 @@
(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)))
@@ -159,42 +416,51 @@
(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)))
- ;TODO: collect isidorus' subjectIdentifiers, itemIdentities,
- ; subjectLocators, names and occurrences
- ; add the collected constructs to the topic-stub
- (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 ((subject-identifiers
+ (make-isidorus-identifiers
+ elem start-revision :what "subjectIdentifier"))
+ (item-identities
+ (make-isidorus-identifiers elem start-revision))
+ (subject-locators
+ (make-isidorus-identifiers 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)
+ ;TDOD: create topic occurrences
+ (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)
@@ -276,7 +542,7 @@
(map 'list #'(lambda(literal)
(make-occurrence owner-top literal start-revision
tm-id :document-id document-id))
- literals))
+ (filter-isidorus-literals literals)))
(defun make-associations (owner-top associations tm start-revision
@@ -408,7 +674,9 @@
(defun make-topic-stub (about ID nodeId UUID start-revision
- tm &key (document-id *document-id*))
+ tm &key (document-id *document-id*)
+ (additional-subject-identifiers nil)
+ (item-identifiers nil) (subject-locators nil))
"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."
@@ -429,15 +697,23 @@
inner-top))))
(if top
top
- (let ((psi (when psi-uri
- (make-instance 'PersistentIdC
- :uri psi-uri
- :start-revision start-revision))))
+ (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 (when psi (list psi))
+ :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"
@@ -917,4 +1193,46 @@
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
+ :xml-lang xml-lang))))))))
+
+
+(defun make-isidorus-identifiers (owner-elem start-revision &key (what "itemIdentity"))
+ "Returns a list oc created identifier objects that can be
+ used directly in make-topic-stub."
+ (declare (dom:element owner-elem))
+ (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 ((content (child-nodes-or-text owner-elem :trim t))
+ (class-symbol (cond
+ ((string= what "itemIdentity")
+ 'ItemIdentifierC)
+ ((string= what "subjectIdentifier")
+ 'PersistentIdC)
+ ((string= what "subjectLocator")
+ 'SubjectLocatorC))))
+ (unless (stringp content)
+ (let ((identifiers
+ (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 (let ((uri (child-nodes-or-text property :trim t)))
+ (make-instance class-symbol
+ :uri uri
+ :start-revision start-revision))))
+ (identifier-attr
+ (let ((attr (get-ns-attribute owner-elem what :ns-uri *tm2rdf-ns*)))
+ (when attr
+ (list (make-instance class-symbol
+ :uri attr
+ :start-revision start-revision))))))
+ (remove-if #'null (append identifiers identifier-attr))))))
\ 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 2 06:58:33 2009
@@ -45,7 +45,15 @@
*tm2rdf-association-property*
*tm2rdf-subjectIdentifier-property*
*tm2rdf-itemIdentity-property*
- *tm2rdf-subjectLocator-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*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
@@ -290,6 +298,29 @@
: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
@@ -501,6 +532,19 @@
(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")))))))
+
+
(defun get-type-psis (elem tm-id
&key (parent-xml-base nil))
"Returns a list of type-uris of the passed node."
@@ -617,6 +661,34 @@
(string= uri property-name-uri))))
+(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil)
+ (ignore-topic nil))
+ "Returns t if the passed element is not of an isidorus' type.
+ The environmental property is not analysed by this function!"
+ (declare (dom:element elem))
+ (declare (string tm-id))
+ (let ((nodeID (get-ns-attribute elem "nodeID"))
+ (document (dom:owner-document elem))
+ (types
+ (let ((b-types
+ (list
+ *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri*
+ *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri*
+ *tm2rdf-role-type-uri*))
+ (a-types (list *tm2rdf-topic-type-uri*)))
+ (if ignore-topic
+ b-types
+ (append a-types b-types)))))
+ (if nodeID
+ (not (loop for type in types
+ when (type-of-id-p nodeId type tm-id document)
+ return t))
+ (not (loop for type in types
+ when (type-p elem type tm-id
+ :parent-xml-base parent-xml-base)
+ return t)))))
+
+
(defun isidorus-type-p (property-elem-or-node-elem tm-id what
&key(parent-xml-base nil))
"Returns t if the node elem is of the type isidorus:<Type> and is
@@ -654,7 +726,16 @@
property-elem-or-node-elem)
(get-node-name property-elem-or-node-elem))))
(if (or (string= type *tm2rdf-topic-type-uri*)
- (string= type *tm2rdf-association-type-uri*))
+ (string= type *tm2rdf-association-type-uri*)
+ (let ((parseType (get-ns-attribute property-elem-or-node-elem
+ "parseType")))
+ (and parseType
+ (string= parseType "Resource")))
+ (get-ns-attribute property-elem-or-node-elem "type")
+ (get-ns-attribute property-elem-or-node-elem "value"
+ :ns-uri *tm2rdf-ns*)
+ (get-ns-attribute property-elem-or-node-elem "itemIdentity"
+ :ns-uri *tm2rdf-ns*))
(type-p property-elem-or-node-elem type tm-id
:parent-xml-base parent-xml-base)
(when (string= elem-uri property)
@@ -686,5 +767,85 @@
(string= x-uri *tm2rdf-role-property*)
(string= x-uri *tm2rdf-subjectIdentifier-property*)
(string= x-uri *tm2rdf-itemIdentity-property*)
+ (string= x-uri *tm2rdf-value-property*)
+ (string= x-uri *tm2rdf-scope-property*)
+ (string= x-uri *tm2rdf-nametype-property*)
+ (string= x-uri *tm2rdf-varianttype-property*)
+ (string= x-uri *tm2rdf-associationtype-property*)
+ (string= x-uri *tm2rdf-occurrencetype-property*)
+ (string= x-uri *tm2rdf-roletype-property*)
(string= x-uri *tm2rdf-subjectLocator-property*))))
- content))))
\ No newline at end of file
+ content))))
+
+
+(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri
+ &key (parent-xml-base nil)
+ (collected-nodes nil))
+ "Returns a list of all nodes that own the given nodeID and are of
+ type type-uri, rdf:Description or when the rdf:parseType is set to
+ Resource or the isidorus:value attribute is set."
+ (declare (dom:element current-node))
+ (declare (string node-id))
+ (let ((datatype (when (get-ns-attribute current-node "datatype")
+ t))
+ (parseType (let ((attr (get-ns-attribute current-node "parseType")))
+ (when (and attr
+ (string= attr "Literal"))
+ t)))
+ (content (child-nodes-or-text current-node :trim t))
+ (xml-base (get-xml-base current-node :old-base parent-xml-base))
+ (nodeID (get-ns-attribute current-node "nodeID"))
+ (node-uri-p (let ((node-uri
+ (concatenate-uri (dom:namespace-uri current-node)
+ (get-node-name current-node)))
+ (description (concatenate 'string *rdf-ns*
+ "Description")))
+ (or (string= node-uri (if type-uri type-uri ""))
+ (string= node-uri description)
+ (get-ns-attribute current-node "type")
+ (get-ns-attribute current-node "value"
+ :ns-uri *tm2rdf-ns*)
+ (get-ns-attribute current-node "itemIdentity"
+ :ns-uri *tm2rdf-ns*)
+ (let ((parseType (get-ns-attribute current-node
+ "parseType")))
+ (when parseType
+ (string= parseType "Resource")))))))
+ (remove-duplicates
+ (remove-if
+ #'null
+ (if (or datatype parseType (stringp content) (not content))
+ (if (and (string= nodeID node-id) node-uri-p)
+ (append (list (list :elem current-node
+ :xml-base xml-base))
+ collected-nodes)
+ collected-nodes)
+ (if (and (string= nodeID node-id) node-uri-p)
+ (loop for item across content
+ append (get-all-isidorus-nodes-by-id
+ node-id item type-uri
+ :collected-nodes (append
+ (list (list :elem current-node
+ :xml-base xml-base))
+ collected-nodes)
+ :parent-xml-base xml-base))
+ (loop for item across content
+ append (get-all-isidorus-nodes-by-id
+ node-id item type-uri
+ :collected-nodes collected-nodes
+ :parent-xml-base xml-base)))))
+ :test #'(lambda(x y)
+ (eql (getf x :elem) (getf y :elem))))))
+
+
+(defun filter-isidorus-literals (literals)
+ "Removes all literals that are known isidorus properties which
+ are able to contain literal data."
+ (remove-if #'(lambda(x)
+ (or (string= (getf x :type)
+ *tm2rdf-subjectIdentifier-property*)
+ (string= (getf x :type)
+ *tm2rdf-itemIdentity-property*)
+ (string= (getf x :type)
+ *tm2rdf-subjectLocator-property*)))
+ literals))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Mon Aug 31 16:01:56 2009
New Revision: 127
Log:
rdf-exporter: fixed a bug with exporting association which has to be mapped as sisidorus:Association nodes
Modified:
trunk/src/xml/rdf/exporter.lisp
Modified: trunk/src/xml/rdf/exporter.lisp
==============================================================================
--- trunk/src/xml/rdf/exporter.lisp (original)
+++ trunk/src/xml/rdf/exporter.lisp Mon Aug 31 16:01:56 2009
@@ -97,7 +97,7 @@
(d:find-item-by-revision top revision))
(if ,tm
(union
- (d:topics ,tm) (d:associations ,tm))
+ (d:topics ,tm) (intersection (list-tm-associations) (d:associations ,tm)))
(union
(elephant:get-instances-by-class 'd:TopicC)
(list-tm-associations)))))))
1
0
Author: lgiessmann
Date: Mon Aug 31 12:20:06 2009
New Revision: 126
Log:
rdf-importer: changed functions that collects resource-information, so properties which contains isidorus contructs are ignored and can be handled separately
Modified:
trunk/src/constants.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 Mon Aug 31 12:20:06 2009
@@ -50,7 +50,10 @@
:*tm2rdf-role-type-uri*
:*tm2rdf-role-property*
:*tm2rdf-association-type-uri*
- :*tm2rdf-associaiton-property*))
+ :*tm2rdf-associaiton-property*
+ :*tm2rdf-subjectIdentifier-property*
+ :*tm2rdf-itemIdentity-property*
+ :*tm2rdf-subjectLocator-property*))
(in-package :constants)
@@ -135,3 +138,9 @@
(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "Association"))
(defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association"))
+
+(defparameter *tm2rdf-subjectIdentifier-property* (concatenate 'string *tm2rdf-ns* "subjectIdentifier"))
+
+(defparameter *tm2rdf-subjectLocator-property* (concatenate 'string *tm2rdf-ns* "subjectLocator"))
+
+(defparameter *tm2rdf-itemIdentity-property* (concatenate 'string *tm2rdf-ns* "itemIdentity"))
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Mon Aug 31 12:20:06 2009
@@ -110,6 +110,12 @@
(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)))
+ ;TODO: collect isidorus' subjectIdentifiers, itemIdentities,
+ ; subjectLocators, names and occurrences
+ ; add the collected constructs to the topic-stub
+
+ ;TODO: collect associations and association roles and create the
+ ; corresponding constructs and stops the recusrion
(with-tm (start-revision document-id tm-id)
(let ((this
(make-topic-stub
@@ -176,6 +182,9 @@
(super-classes
(get-super-classes-of-node-content
elem tm-id xml-base)))
+ ;TODO: collect isidorus' subjectIdentifiers, itemIdentities,
+ ; subjectLocators, names and occurrences
+ ; add the collected constructs to the topic-stub
(make-literals this literals tm-id start-revision
:document-id document-id)
(make-associations this associations xml-importer::tm
@@ -580,7 +589,7 @@
"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))
+ (let ((properties (non-isidorus-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
@@ -605,8 +614,6 @@
(not (or prop-literals type))
(string/= parseType "Collection")
(string/= parseType "Resource")))
-
-
collect (let ((content (child-nodes-or-text property))
(ID (get-absolute-attribute property tm-id
fn-xml-base "ID"))
@@ -651,8 +658,8 @@
:ID nil))
nil))
(content-types
- (when (child-nodes-or-text node :trim t)
- (loop for child across (child-nodes-or-text node :trim t)
+ (when (non-isidorus-child-nodes-or-text node :trim t)
+ (loop for child across (non-isidorus-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"))
@@ -766,7 +773,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 (child-nodes-or-text node :trim t))
+ (let ((content (non-isidorus-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
@@ -799,7 +806,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 (child-nodes-or-text node :trim t))
+ (let ((properties (non-isidorus-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))
@@ -859,7 +866,7 @@
"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))
+ (let ((content (non-isidorus-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)))
@@ -878,7 +885,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 (child-nodes-or-text arc))
+ (content (non-isidorus-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"))
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Mon Aug 31 12:20:06 2009
@@ -42,7 +42,10 @@
*tm2rdf-role-type-uri*
*tm2rdf-role-property*
*tm2rdf-association-type-uri*
- *tm2rdf-association-property*)
+ *tm2rdf-association-property*
+ *tm2rdf-subjectIdentifier-property*
+ *tm2rdf-itemIdentity-property*
+ *tm2rdf-subjectLocator-property*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
@@ -662,4 +665,26 @@
(when (and (= (length content) 1)
(not (stringp content)))
(type-p (elt content 0) type tm-id
- :parent-xml-base xml-base))))))))))
\ No newline at end of file
+ :parent-xml-base xml-base))))))))))
+
+
+(defun non-isidorus-child-nodes-or-text (elem &key (trim nil))
+ "Returns a list of node elements that are no isidorus properties, e.g.
+ isidorus:name, string-content or nil."
+ (let ((content (child-nodes-or-text elem :trim trim)))
+ (if (or (not content)
+ (stringp content))
+ content
+ (remove-if #'(lambda(x)
+ (let ((x-uri (if (dom:namespace-uri x)
+ (concatenate-uri (dom:namespace-uri x)
+ (get-node-name x))
+ (get-node-name x))))
+ (or (string= x-uri *tm2rdf-name-property*)
+ (string= x-uri *tm2rdf-variant-property*)
+ (string= x-uri *tm2rdf-occurrence-property*)
+ (string= x-uri *tm2rdf-role-property*)
+ (string= x-uri *tm2rdf-subjectIdentifier-property*)
+ (string= x-uri *tm2rdf-itemIdentity-property*)
+ (string= x-uri *tm2rdf-subjectLocator-property*))))
+ content))))
\ No newline at end of file
1
0
Author: lgiessmann
Date: Mon Aug 31 11:30:16 2009
New Revision: 125
Log:
rdf-importer: added some helper functions to be able to recognize constructs that were imported by isidorus, e.g. isidorus:name, etc.
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/rdf_importer_test.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 Mon Aug 31 11:30:16 2009
@@ -39,7 +39,19 @@
:*rdf2tm-object*
:*rdf2tm-subject*
:*rdf2tm-scope-prefix*
- :*tm2rdf-ns*))
+ :*tm2rdf-ns*
+ :*tm2rdf-topic-type-uri*
+ :*tm2rdf-name-type-uri*
+ :*tm2rdf-name-property*
+ :*tm2rdf-variant-type-uri*
+ :*tm2rdf-variant-property*
+ :*tm2rdf-occurrence-type-uri*
+ :*tm2rdf-occurrence-property*
+ :*tm2rdf-role-type-uri*
+ :*tm2rdf-role-property*
+ :*tm2rdf-association-type-uri*
+ :*tm2rdf-associaiton-property*))
+
(in-package :constants)
(defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/")
@@ -80,24 +92,46 @@
(defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/")
-(defparameter *rdf-statement* "http://www.w3.org/1999/02/22-rdf-syntax-ns#Statement")
+(defparameter *rdf-statement* (concatenate 'string *rdf-ns* "Statement"))
-(defparameter *rdf-object* "http://www.w3.org/1999/02/22-rdf-syntax-ns#object")
+(defparameter *rdf-object* (concatenate 'string *rdf-ns* "object"))
-(defparameter *rdf-subject* "http://www.w3.org/1999/02/22-rdf-syntax-ns#subject")
+(defparameter *rdf-subject* (concatenate 'string *rdf-ns* "subject"))
-(defparameter *rdf-predicate* "http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate")
+(defparameter *rdf-predicate* (concatenate 'string *rdf-ns* "predicate"))
-(defparameter *rdf-nil* "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")
+(defparameter *rdf-nil* (concatenate 'string *rdf-ns* "nil"))
-(defparameter *rdf-first* "http://www.w3.org/1999/02/22-rdf-syntax-ns#first")
+(defparameter *rdf-first* (concatenate 'string *rdf-ns* "first"))
-(defparameter *rdf-rest* "http://www.w3.org/1999/02/22-rdf-syntax-ns#rest")
+(defparameter *rdf-rest* (concatenate 'string *rdf-ns* "rest"))
-(defparameter *rdf2tm-object* "http://isidorus/rdf2tm_mapping/object")
+(defparameter *rdf2tm-object* (concatenate 'string *rdf2tm-ns* "object"))
-(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping/subject")
+(defparameter *rdf2tm-subject* (concatenate 'string *rdf2tm-ns* "subject"))
-(defparameter *rdf2tm-scope-prefix* "http://isidorus/rdf2tm_mapping/scope/")
+(defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/"))
-(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
\ No newline at end of file
+(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
+
+(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "Topic"))
+
+(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "Name"))
+
+(defparameter *tm2rdf-name-property* (concatenate 'string *tm2rdf-ns* "name"))
+
+(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "Variant"))
+
+(defparameter *tm2rdf-variant-property* (concatenate 'string *tm2rdf-ns* "variant"))
+
+(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "Occurrence"))
+
+(defparameter *tm2rdf-occurrence-property* (concatenate 'string *tm2rdf-ns* "occurrence"))
+
+(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "Role"))
+
+(defparameter *tm2rdf-role-property* (concatenate 'string *tm2rdf-ns* "role"))
+
+(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "Association"))
+
+(defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association"))
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 Mon Aug 31 11:30:16 2009
@@ -18,6 +18,7 @@
*rdf-ns*
*rdfs-ns*
*rdf2tm-ns*
+ *tm2rdf-ns*
*xml-ns*
*xml-string*
*instance-psi*
@@ -32,7 +33,13 @@
*rdf-subject*
*rdf-object*
*rdf-predicate*
- *rdf-statement*)
+ *rdf-statement*
+ *tm2rdf-topic-type-uri*
+ *tm2rdf-name-type-uri*
+ *tm2rdf-variant-type-uri*
+ *tm2rdf-occurrence-type-uri*
+ *tm2rdf-role-type-uri*
+ *tm2rdf-association-type-uri*)
(:import-from :xml-tools
xpath-child-elems-by-qname
xpath-single-child-elem-by-qname
@@ -59,7 +66,10 @@
:test-poems-rdf-topics
:test-empty-collection
:test-collection
- :test-xml-base))
+ :test-xml-base
+ :test-get-type-psis
+ :test-get-all-type-psis
+ :test-isidorus-type-p))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -3054,7 +3064,200 @@
"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)))))))
+
+
(defun run-rdf-importer-tests()
+ "Runs all defined tests."
(when elephant:*store-controller*
(elephant:close-store))
(it.bese.fiveam:run! 'test-get-literals-of-node)
@@ -3075,4 +3278,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-get-type-psis)
+ (it.bese.fiveam:run! 'test-get-all-type-psis)
+ (it.bese.fiveam:run! 'test-isidorus-type-p))
\ 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 Mon Aug 31 11:30:16 2009
@@ -96,8 +96,7 @@
(format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove
(tm-id-p tm-id "import-node")
(parse-node elem)
- (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
- (fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
+ (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"))
@@ -108,16 +107,7 @@
(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 (list
- (unless (string= (get-type-of-node-name elem)
- (concatenate 'string *rdf-ns*
- "Description"))
- (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 fn-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)
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Mon Aug 31 11:30:16 2009
@@ -31,7 +31,18 @@
*rdf-nil*
*rdf-first*
*rdf-rest*
- *rdf2tm-scope-prefix*)
+ *rdf2tm-scope-prefix*
+ *tm2rdf-topic-type-uri*
+ *tm2rdf-name-type-uri*
+ *tm2rdf-name-property*
+ *tm2rdf-variant-type-uri*
+ *tm2rdf-variant-property*
+ *tm2rdf-occurrence-type-uri*
+ *tm2rdf-occurrence-property*
+ *tm2rdf-role-type-uri*
+ *tm2rdf-role-property*
+ *tm2rdf-association-type-uri*
+ *tm2rdf-association-property*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
@@ -369,8 +380,7 @@
datatype))
(when (and (or nodeID resource)
(> (length content) 0))
- ;(set-_n-name property _n-counter)))
- (error "~awhen ~a is set no content is allowed: ~a!"
+ (error "~awhen ~a is set no content is allowed: ~a!"
err-pref
(cond
(nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
@@ -469,4 +479,187 @@
"Checks the validity of the passed tm-id."
(unless (absolute-uri-p tm-id)
(error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!"
- fun-name tm-id)))
\ No newline at end of file
+ fun-name tm-id)))
+
+
+(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)))))
+
+
+(defun get-type-psis (elem tm-id
+ &key (parent-xml-base nil))
+ "Returns a list of type-uris of the passed node."
+ (let ((types (get-types-of-node elem tm-id
+ :parent-xml-base parent-xml-base)))
+ (remove-if #'null
+ (map 'list #'(lambda(x)
+ (getf x :psi))
+ types))))
+
+
+(defun get-all-type-psis-of-id (nodeID tm-id document)
+ "Returns a list of type-uris for resources identified by the given
+ nodeID by analysing the complete XML-DOM."
+ (let ((root (elt (dom:child-nodes document) 0)))
+ (remove-duplicates
+ (remove-if #'null
+ (if (and (string= (dom:namespace-uri root) *rdf-ns*)
+ (string= (get-node-name root)"RDF"))
+ (loop for node across (child-nodes-or-text root)
+ append (get-all-type-psis-across-dom
+ root tm-id :resource-id nodeID))
+ (get-all-type-psis-across-dom
+ root tm-id :resource-id nodeID)))
+ :test #'string=)))
+
+
+(defun get-all-type-psis (elem tm-id &key (parent-xml-base nil))
+ "Returns a list of type-uris for the element by analysing the complete
+ XML-DOM."
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+ (let ((root (elt (dom:child-nodes (dom:owner-document elem)) 0))
+ (nodeID (get-ns-attribute elem "nodeID"))
+ (about (get-absolute-attribute elem tm-id xml-base "about")))
+ (remove-duplicates
+ (remove-if #'null
+ (if (or nodeID about)
+ (if (and (string= (dom:namespace-uri root) *rdf-ns*)
+ (string= (get-node-name root) "RDF"))
+ (loop for node across (child-nodes-or-text root)
+ append (get-all-type-psis-across-dom
+ root tm-id :resource-uri about
+ :resource-id nodeID))
+ (get-all-type-psis-across-dom
+ root tm-id :resource-uri about
+ :resource-id nodeID))
+ (get-type-psis elem tm-id :parent-xml-base parent-xml-base)))
+ :test #'string=))))
+
+
+(defun get-all-type-psis-across-dom (elem tm-id &key (parent-xml-base nil)
+ (resource-uri nil) (resource-id nil)
+ (types nil))
+ "Returns a list of type PSI strings collected over the complete XML-DOM
+ corresponding to the passed id's or uri."
+ (when (or resource-uri resource-id)
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+ (let ((datatype (when (get-ns-attribute elem "datatype")
+ t))
+ (parseType (when (get-ns-attribute elem "parseType")
+ (string= (get-ns-attribute elem "parseType")
+ "Literal"))))
+ (if (or datatype parseType)
+ types
+ (let ((nodeID (get-ns-attribute elem "nodeID"))
+ (about (get-absolute-attribute elem tm-id xml-base "about")))
+ (let ((fn-types
+ (append types
+ (when (or (and about resource-uri
+ (string= about resource-uri))
+ (and nodeID resource-id
+ (string= nodeID resource-id)))
+ (get-type-psis elem tm-id
+ :parent-xml-base xml-base))))
+ (content (child-nodes-or-text elem :trim t)))
+ (if (or (stringp content)
+ (not content))
+ fn-types
+ (loop for child-node across content
+ append (get-all-type-psis-across-dom
+ child-node tm-id :parent-xml-base xml-base
+ :resource-uri resource-uri
+ :resource-id resource-id
+ :types fn-types))))))))))
+
+
+(defun type-p (elem type-uri tm-id &key (parent-xml-base nil))
+ "Returns t if the type-uri is a type of elem."
+ (declare (string tm-id type-uri))
+ (declare (dom:element elem))
+ (tm-id-p tm-id "type-p")
+ (find type-uri (get-all-type-psis elem tm-id
+ :parent-xml-base parent-xml-base)
+ :test #'string=))
+
+
+(defun type-of-id-p (node-id type-uri tm-id document)
+ "Returns t if type-uri is a type of the passed node-id."
+ (declare (string node-id type-uri tm-id))
+ (declare (dom:document document))
+ (tm-id-p tm-id "type-of-ndoe-id-p")
+ (find type-uri (get-all-type-psis-of-id node-id tm-id document)
+ :test #'string=))
+
+
+(defun property-name-of-node-p (elem property-name-uri)
+ "Returns t if the elements tag-name and namespace are equal
+ to the given uri."
+ (declare (dom:element elem))
+ (declare (string property-name-uri))
+ (when property-name-uri
+ (let ((uri (concatenate-uri (dom:namespace-uri elem)
+ (get-node-name elem))))
+ (string= uri property-name-uri))))
+
+
+(defun isidorus-type-p (property-elem-or-node-elem tm-id what
+ &key(parent-xml-base nil))
+ "Returns t if the node elem is of the type isidorus:<Type> and is
+ contained in a porperty isidorus:<type>."
+ (declare (dom:element property-elem-or-node-elem))
+ (declare (symbol what))
+ (tm-id-p tm-id "isidorus-type-p")
+ (let ((xml-base (get-xml-base property-elem-or-node-elem
+ :old-base parent-xml-base))
+ (type-and-property (cond
+ ((eql what 'name)
+ (list :type *tm2rdf-name-type-uri*
+ :property *tm2rdf-name-property*))
+ ((eql what 'variant)
+ (list :type *tm2rdf-variant-type-uri*
+ :property *tm2rdf-variant-property*))
+ ((eql what 'occurrence)
+ (list :type *tm2rdf-occurrence-type-uri*
+ :property *tm2rdf-occurrence-property*))
+ ((eql what 'role)
+ (list :type *tm2rdf-role-type-uri*
+ :property *tm2rdf-role-property*))
+ ((eql what 'topic)
+ (list :type *tm2rdf-topic-type-uri*))
+ ((eql what 'association)
+ (list :type
+ *tm2rdf-association-type-uri*)))))
+ (when type-and-property
+ (let ((type (getf type-and-property :type))
+ (property (getf type-and-property :property))
+ (nodeID (get-ns-attribute property-elem-or-node-elem "nodeID"))
+ (document (dom:owner-document property-elem-or-node-elem))
+ (elem-uri (concatenate-uri
+ (dom:namespace-uri
+ property-elem-or-node-elem)
+ (get-node-name property-elem-or-node-elem))))
+ (if (or (string= type *tm2rdf-topic-type-uri*)
+ (string= type *tm2rdf-association-type-uri*))
+ (type-p property-elem-or-node-elem type tm-id
+ :parent-xml-base parent-xml-base)
+ (when (string= elem-uri property)
+ (if nodeID
+ (type-of-id-p nodeId type tm-id document)
+ (let ((content (child-nodes-or-text property-elem-or-node-elem
+ :trim t)))
+ (when (and (= (length content) 1)
+ (not (stringp content)))
+ (type-p (elt content 0) type tm-id
+ :parent-xml-base xml-base))))))))))
\ No newline at end of file
1
0