[isidorus-cvs] r145 - in trunk/src: model unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Sun Nov 22 18:16:49 UTC 2009
Author: lgiessmann
Date: Sun Nov 22 13:16:47 2009
New Revision: 145
Log:
added the support for reification in the xtm 2.0 importer
Modified:
trunk/src/model/datamodel.lisp
trunk/src/unit_tests/reification_test.lisp
trunk/src/xml/xtm/importer_xtm2.0.lisp
Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp (original)
+++ trunk/src/model/datamodel.lisp Sun Nov 22 13:16:47 2009
@@ -1615,6 +1615,7 @@
(merge-reifier-topics (reifier construct) reifier-topic))))))
construct))
+
(defgeneric merge-reifier-topics (old-topic new-topic)
;;the reifier topics are not only merged but also bound to the reified-construct
(:method ((old-topic TopicC) (new-topic TopicC))
@@ -1632,8 +1633,10 @@
(dolist (scoped-construct (used-as-theme new-topic))
(remove-association scoped-construct 'themes new-topic)
(add-association scoped-construct 'themes old-topic))
+ ;merges all topic-maps
(dolist (tm (in-topicmaps new-topic))
(add-association tm 'topic old-topic)) ;the new-topic is removed from this tm by deleting it
+ ;merges all role-players
(dolist (a-role (player-in-roles new-topic))
(remove-association a-role 'player new-topic)
(add-association a-role 'player old-topic))
Modified: trunk/src/unit_tests/reification_test.lisp
==============================================================================
--- trunk/src/unit_tests/reification_test.lisp (original)
+++ trunk/src/unit_tests/reification_test.lisp Sun Nov 22 13:16:47 2009
@@ -96,6 +96,20 @@
:topicid "name-type"
:xtm-id xtm-id-1
:start-revision revision-1))
+ (assoc-type (make-construct 'TopicC
+ :psis (list (make-instance 'PersistentIdC
+ :uri "psi-assoc-type"
+ :start-revision revision-1))
+ :topicid "assoc-type"
+ :xtm-id xtm-id-1
+ :start-revision revision-1))
+ (role-type (make-construct 'TopicC
+ :psis (list (make-instance 'PersistentIdC
+ :uri "psi-role-type"
+ :start-revision revision-1))
+ :topicid "assoc-type"
+ :xtm-id xtm-id-1
+ :start-revision revision-1))
(occurrence-type (make-construct 'TopicC
:psis (list (make-instance 'PersistentIdC
:uri "psi-occurrence-type"
@@ -143,10 +157,29 @@
:themes (list scope-1 topic-2)
:instance-of topic-2
:charvalue "test-name"
- :start-revision revision-2)))
- (is (= (length (elephant:get-instances-by-class 'TopicC)) 6))
+ :start-revision revision-2))
+ (assoc (make-construct 'AssociationC
+ :item-identifiers nil
+ :instance-of assoc-type
+ :themes nil
+ :roles
+ (list
+ (list :instance-of role-type
+ :player topic-1
+ :item-identifiers
+ (list (make-instance 'ItemIdentifierC
+ :uri "role-1"
+ :start-revision revision-1)))
+ (list :instance-of role-type
+ :player topic-2
+ :item-identifiers
+ (list (make-instance 'ItemIdentifierC
+ :uri "role-2"
+ :start-revision revision-1))))
+ :start-revision revision-1)))
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 8))
(datamodel::merge-reifier-topics topic-1 topic-2)
- (is (= (length (elephant:get-instances-by-class 'TopicC)) 5))
+ (is (= (length (elephant:get-instances-by-class 'TopicC)) 7))
(is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2)
(item-identifiers topic-1)))
(length (list ii-1-1 ii-1-2 ii-2-1 ii-2-2))))
@@ -168,11 +201,18 @@
(is (= (length (union (d:used-as-theme topic-1)
(list test-name)))
(length (list test-name))))
- ;;TODO: roleplayer, topicmap
+ (is (eql (player (first (roles assoc))) topic-1))
+ (is (eql (player (second (roles assoc))) topic-1))
;;TODO: check all objects and their version-infos
(elephant:close-store))))))
+;;TODO: check xtm1.0 importer
+;;TODO: check xtm2.0 importer
+;;TODO: check rdf importer
+;;TODO: check fragment exporter
+
+
(defun run-reification-tests ()
(it.bese.fiveam:run! 'test-merge-reifier-topics)
)
\ No newline at end of file
Modified: trunk/src/xml/xtm/importer_xtm2.0.lisp
==============================================================================
--- trunk/src/xml/xtm/importer_xtm2.0.lisp (original)
+++ trunk/src/xml/xtm/importer_xtm2.0.lisp Sun Nov 22 13:16:47 2009
@@ -9,6 +9,17 @@
(in-package :xml-importer)
+(defun set-reifier (reifiable-elem reifiable-construct)
+ "Sets the reifier-topic of the passed elem to the passed construct."
+ (declare (dom:element reifiable-elem))
+ (declare (ReifiableConstructC reifiable-construct))
+ (let ((reifier-uri (get-attribute reifiable-elem "reifier")))
+ (when (and (stringp reifier-uri)
+ (> (length reifier-uri) 0))
+ (add-reifier reifiable-construct reifier-uri))
+ reifiable-construct))
+
+
(defun from-identifier-elem (classsymbol elem start-revision)
"Generate an identifier object of type 'classsymbol' (a subclass of
IdentifierC) from a given identifier element for a revision and return
@@ -127,7 +138,7 @@
:themes themes)))
(loop for variant-elem across (xpath-child-elems-by-qname name-elem *xtm2.0-ns* "variant")
do (from-variant-elem variant-elem name start-revision :xtm-id xtm-id))
- name)))
+ (set-reifier name-elem name))))
(defun from-resourceX-elem (parent-elem)
@@ -180,13 +191,14 @@
(unless variant-value
(error "VariantC: one of resourceRef and resourceData must be set"))
- (make-construct 'VariantC
- :start-revision start-revision
- :item-identifiers item-identifiers
- :themes themes
- :charvalue (getf variant-value :data)
- :datatype (getf variant-value :type)
- :name name)))
+ (let ((variant (make-construct 'VariantC
+ :start-revision start-revision
+ :item-identifiers item-identifiers
+ :themes themes
+ :charvalue (getf variant-value :data)
+ :datatype (getf variant-value :type)
+ :name name)))
+ (set-reifier variant-elem variant))))
(defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*))
@@ -211,14 +223,15 @@
(occurrence-value (from-resourceX-elem occ-elem)))
(unless occurrence-value
(error "OccurrenceC: one of resourceRef and resourceData must be set"))
- (make-construct 'OccurrenceC
- :start-revision start-revision
- :topic top
- :themes themes
- :item-identifiers item-identifiers
- :instance-of instance-of
- :charvalue (getf occurrence-value :data)
- :datatype (getf occurrence-value :type))))
+ (let ((occurrence (make-construct 'OccurrenceC
+ :start-revision start-revision
+ :topic top
+ :themes themes
+ :item-identifiers item-identifiers
+ :instance-of instance-of
+ :charvalue (getf occurrence-value :data)
+ :datatype (getf occurrence-value :type))))
+ (set-reifier occ-elem occurrence))))
@@ -322,7 +335,13 @@
(xpath-single-child-elem-by-qname
role-elem
*xtm2.0-ns*
- "topicRef")) :xtm-id xtm-id)))
+ "topicRef")) :xtm-id xtm-id))
+ (reifier-uri
+ (let ((value (get-attribute role-elem "reifier")))
+ (if (and (stringp value)
+ (> (length value) 0))
+ value
+ nil))))
; (unless (and player instance-of)
; (error "Role in association not complete"))
(unless player ;instance-of will be set later - if there is no one
@@ -331,7 +350,10 @@
role-elem
*xtm2.0-ns*
"topicRef"))))
- (list :instance-of instance-of :player player :item-identifiers item-identifiers))))
+ (list :reifier-uri reifier-uri
+ :instance-of instance-of
+ :player player
+ :item-identifiers item-identifiers))))
(defun from-association-elem (assoc-elem start-revision
@@ -339,7 +361,7 @@
tm
(xtm-id *current-xtm*))
"Constructs an AssociationC object from an association element
-association = element association { reifiable, type, scope?, role+ }"
+ association = element association { reifiable, type, scope?, role+ }"
(declare (dom:element assoc-elem))
(declare (integer start-revision))
(declare (TopicMapC tm))
@@ -366,14 +388,25 @@
assoc-elem
*xtm2.0-ns* "role"))))
(setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them
-
- (add-to-topicmap tm
- (make-construct 'AssociationC
- :start-revision start-revision
- :item-identifiers item-identifiers
- :instance-of instance-of
- :themes themes
- :roles roles)))))
+ (let ((assoc (add-to-topicmap
+ tm
+ (make-construct 'AssociationC
+ :start-revision start-revision
+ :item-identifiers item-identifiers
+ :instance-of instance-of
+ :themes themes
+ :roles roles))))
+ (map 'list #'(lambda(assoc-role)
+ (map 'list #'(lambda(list-role)
+ (when (and (eql (instance-of assoc-role)
+ (getf list-role :instance-of))
+ (eql (player assoc-role)
+ (getf list-role :player))
+ (getf list-role :reifier-uri))
+ (add-reifier assoc-role (getf list-role :reifier-uri))))
+ roles))
+ (roles assoc))
+ (set-reifier assoc-elem assoc)))))
More information about the Isidorus-cvs
mailing list