[isidorus-cvs] r134 - in trunk/src: model xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Sep 7 11:21:34 UTC 2009
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*)
More information about the Isidorus-cvs
mailing list