Author: lgiessmann Date: Sun Nov 22 15:11:48 2009 New Revision: 146
Log: added the support of reification in xtm1.0
Modified: trunk/src/model/datamodel.lisp trunk/src/xml/xtm/importer_xtm1.0.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 15:11:48 2009 @@ -1585,34 +1585,36 @@ ;;;;;;;;;;;;;;;;; ;; reification
-(defgeneric add-reifier (construct reifier-uri) - (:method ((construct ReifiableConstructC) reifier-uri) +(defgeneric add-reifier (construct reifier-uri reifier-must-exist) + (:method ((construct ReifiableConstructC) reifier-uri reifier-must-exist) (let ((err "From add-reifier(): ")) (let ((item-identifier - (elephant:get-instance-by-value 'Item-IdentifierC 'uri reifier-uri))) + (elephant:get-instance-by-value 'ItemIdentifierC 'uri reifier-uri))) (unless item-identifier - (error "~ano item-identifier could be found with the uri ~a" - err reifier-uri)) - (let ((reifier-topic (identified-construct item-identifier))) - (unless (typep reifier-topic 'TopicC) - (error "~anitem-identifier ~a must be bound to a topic, but is ~a" - err reifier-uri (type-of reifier-topic))) - (cond - ((and (not (reifier construct)) - (not (reified reifier-topic))) - (setf (reifier construct) reifier-topic)) - ((and (not (reified reifier-topic)) - (reifier construct)) - (merge-reifier-topics (reifier construct) reifier-topic)) - ((and (not (reifier construct)) - (reified reifier-topic)) - (error "~a~a reifies already another object ~a" - err reifier-uri (reified reifier-topic))) - (t - (when (not (eql (reified reifier-topic) construct)) + (when reifier-must-exist + (error "~ano item-identifier could be found with the uri ~a" + err reifier-uri))) + (when item-identifier + (let ((reifier-topic (identified-construct item-identifier))) + (unless (typep reifier-topic 'TopicC) + (error "~anitem-identifier ~a must be bound to a topic, but is ~a" + err reifier-uri (type-of reifier-topic))) + (cond + ((and (not (reifier construct)) + (not (reified reifier-topic))) + (setf (reifier construct) reifier-topic)) + ((and (not (reified reifier-topic)) + (reifier construct)) + (merge-reifier-topics (reifier construct) reifier-topic)) + ((and (not (reifier construct)) + (reified reifier-topic)) (error "~a~a reifies already another object ~a" err reifier-uri (reified reifier-topic))) - (merge-reifier-topics (reifier construct) reifier-topic)))))) + (t + (when (not (eql (reified reifier-topic) construct)) + (error "~a~a reifies already another object ~a" + err reifier-uri (reified reifier-topic))) + (merge-reifier-topics (reifier construct) reifier-topic))))))) construct))
Modified: trunk/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- trunk/src/xml/xtm/importer_xtm1.0.lisp (original) +++ trunk/src/xml/xtm/importer_xtm1.0.lisp Sun Nov 22 15:11:48 2009 @@ -9,6 +9,19 @@
(in-package :xml-importer)
+(defun set-reifier-xtm1.0 (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 + (when (dom:get-attribute-node reifiable-elem "id") + (dom:node-value (dom:get-attribute-node reifiable-elem "id"))))) + (when (and (stringp reifier-uri) + (> (length reifier-uri) 0)) + (add-reifier reifiable-construct (concatenate 'string "#" reifier-uri) nil)) + reifiable-construct)) + + (defun get-topic-id-xtm1.0 (topic-elem) "returns the id attribute of a topic element" (declare (dom:element topic-elem)) @@ -77,6 +90,7 @@ :charvalue (getf variantName :data) :datatype (getf variantName :type) :name parent-name))) + (set-reifier-xtm1.0 variant-elem variant) (let ((inner-variants (map 'list #'(lambda(x) (from-variant-elem-xtm1.0 x variant start-revision :xtm-id xtm-id)) @@ -138,6 +152,7 @@ :topic top :charvalue baseNameString :themes themes))) + (set-reifier-xtm1.0 baseName-elem name) (map 'list #'(lambda(x) (from-variant-elem-xtm1.0 x name start-revision :xtm-id xtm-id)) (xpath-child-elems-by-qname baseName-elem *xtm1.0-ns* "variant")) @@ -248,13 +263,14 @@ (unless instanceOf (format t "from-occurrence-elem-xtm1.0: type is missing -> http://psi.topicmaps.org/iso13250/model/type-instance~%") (setf instanceOf (get-item-by-id "type-instance" :xtm-id "core.xtm"))) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes themes - :instance-of instanceOf - :charvalue (getf occurrence-value :data) - :datatype (getf occurrence-value :type)))) + (let ((occurrence (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes themes + :instance-of instanceOf + :charvalue (getf occurrence-value :data) + :datatype (getf occurrence-value :type)))) + (set-reifier-xtm1.0 occ-elem occurrence))))
(defun from-subjectIdentity-elem-xtm1.0 (subjectIdentity-elem start-revision) @@ -308,11 +324,17 @@ (xpath-child-elems-by-qname member-elem *xtm1.0-ns* - "subjectIndicatorRef")))))))) + "subjectIndicatorRef"))))))) + (reifier-uri + (when (dom:get-attribute-node member-elem "id") + (concatenate 'string "#" (dom:node-value (dom:get-attribute-node member-elem "id")))))) (declare (dom:element member-elem)) (unless player ; if no type is given a standard type will be assigend later in from-assoc... (error "from-member-elem-xtm1.0: missing player in role")) - (list :instance-of type :player (first player) :item-identifiers nil))))) + (list :instance-of type + :player (first player) + :item-identifiers nil + :reifier-uri reifier-uri)))))
(defun from-topic-elem-to-stub-xtm1.0 (topic-elem start-revision @@ -399,9 +421,19 @@ :instance-of type :themes themes :roles roles))) - (add-to-topicmap tm association) - association)))) - + (add-to-topicmap tm association) + (set-reifier-xtm1.0 assoc-elem association) + (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) nil))) + roles)) + (roles association)))))) +
(defun set-standard-role-types (roles) "sets the missing role types of the passed roles to the default types."
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 15:11:48 2009 @@ -16,7 +16,7 @@ (let ((reifier-uri (get-attribute reifiable-elem "reifier"))) (when (and (stringp reifier-uri) (> (length reifier-uri) 0)) - (add-reifier reifiable-construct reifier-uri)) + (add-reifier reifiable-construct reifier-uri t)) reifiable-construct))
@@ -403,7 +403,7 @@ (eql (player assoc-role) (getf list-role :player)) (getf list-role :reifier-uri)) - (add-reifier assoc-role (getf list-role :reifier-uri)))) + (add-reifier assoc-role (getf list-role :reifier-uri) t))) roles)) (roles assoc)) (set-reifier assoc-elem assoc)))))