[isidorus-cvs] r172 - in trunk/src: model xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Sat Dec 12 00:29:02 UTC 2009
Author: lgiessmann
Date: Fri Dec 11 19:29:01 2009
New Revision: 172
Log:
added some more beauty to the xtm-importers in the reification-sections :-)
Modified:
trunk/src/model/datamodel.lisp
trunk/src/xml/rdf/importer.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 Fri Dec 11 19:29:01 2009
@@ -1450,12 +1450,13 @@
(declare (list roles))
(let
((association (call-next-method)))
- (dolist (role-tuple roles)
+ (dolist (role-data roles)
(make-instance
'RoleC
- :instance-of (getf role-tuple :instance-of)
- :player (getf role-tuple :player)
- :item-identifiers (getf role-tuple :item-identifiers)
+ :instance-of (getf role-data :instance-of)
+ :player (getf role-data :player)
+ :item-identifiers (getf role-data :item-identifiers)
+ :reifier (getf role-data :reifier)
:parent association))))
(defmethod make-construct :around ((class-symbol (eql 'AssociationC))
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Fri Dec 11 19:29:01 2009
@@ -354,10 +354,6 @@
: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
@@ -399,10 +395,6 @@
: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
@@ -509,9 +501,6 @@
: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
@@ -560,44 +549,6 @@
:document-id document-id)))
(add-reifier reifiable-construct reifier-topic)))
-;(defun make-reification (reifier-id subject object predicate start-revision tm
-; &key document-id)
-; "Creates a reification construct."
-; (declare (string reifier-id))
-; (declare ((or OccurrenceC TopicC) object))
-; (declare (TopicC subject predicate))
-; (declare (TopicMapC tm))
-; (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))
-; (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
&key (document-id *document-id*))
@@ -628,8 +579,6 @@
:charvalue value
:datatype datatype)))
(when ID
- ;(make-reification ID top occurrence type-top start-revision
- ; xml-importer::tm :document-id document-id))
(make-reification ID occurrence start-revision xml-importer::tm
:document-id document-id))
occurrence))))))
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 Fri Dec 11 19:29:01 2009
@@ -9,10 +9,9 @@
(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."
+(defun get-reifier-topic-xtm1.0 (reifiable-elem)
+ "Returns a reifier topic of the reifiable-element or nil."
(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")))))
@@ -24,8 +23,7 @@
(when psi
(let ((reifier-topic (identified-construct psi)))
(when reifier-topic
- (add-reifier reifiable-construct reifier-topic)))))))
- reifiable-construct)
+ reifier-topic)))))))
(defun get-topic-id-xtm1.0 (topic-elem)
@@ -87,7 +85,8 @@
((typep parent-construct 'VariantC)
(name parent-construct))
(t
- (error "from-variant-elem-xtm1.0: parent-cosntruct is neither NameC nor VariantC")))))
+ (error "from-variant-elem-xtm1.0: parent-construct is neither NameC nor VariantC"))))
+ (reifier-topic (get-reifier-topic-xtm1.0 variant-elem)))
(unless (and variantName parameters)
(error "from-variant-elem-xtm1.0: parameters and variantName must be set"))
(let ((variant (make-construct 'VariantC
@@ -95,8 +94,8 @@
:themes parameters
:charvalue (getf variantName :data)
:datatype (getf variantName :type)
+ :reifier reifier-topic
: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))
@@ -149,7 +148,8 @@
(xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "scope")
:xtm-id xtm-id)))
(baseNameString (xpath-fn-string
- (xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "baseNameString"))))
+ (xpath-single-child-elem-by-qname baseName-elem *xtm1.0-ns* "baseNameString")))
+ (reifier-topic (get-reifier-topic-xtm1.0 baseName-elem)))
(unless baseNameString
(error "A baseName must have exactly one baseNameString"))
@@ -157,8 +157,8 @@
:start-revision start-revision
:topic top
:charvalue baseNameString
+ :reifier reifier-topic
: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"))
@@ -262,21 +262,22 @@
(themes (from-scope-elem-xtm1.0
(xpath-single-child-elem-by-qname occ-elem *xtm1.0-ns* "scope")
:xtm-id xtm-id))
- (occurrence-value
- (from-resourceX-elem-xtm1.0 occ-elem)))
+ (occurrence-value
+ (from-resourceX-elem-xtm1.0 occ-elem))
+ (reifier-topic (get-reifier-topic-xtm1.0 occ-elem)))
(unless occurrence-value
(error "from-occurrence-elem-xtm1.0: one of resourceRef and resourceData must be set"))
(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")))
- (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))))
+ (make-construct 'OccurrenceC
+ :start-revision start-revision
+ :topic top
+ :themes themes
+ :instance-of instanceOf
+ :charvalue (getf occurrence-value :data)
+ :reifier reifier-topic
+ :datatype (getf occurrence-value :type))))
(defun from-subjectIdentity-elem-xtm1.0 (subjectIdentity-elem start-revision)
@@ -331,16 +332,14 @@
member-elem
*xtm1.0-ns*
"subjectIndicatorRef")))))))
- (reifier-uri
- (when (dom:get-attribute-node member-elem "id")
- (concatenate 'string "#" (dom:node-value (dom:get-attribute-node member-elem "id"))))))
+ (reifier-topic (get-reifier-topic-xtm1.0 member-elem)))
(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
- :reifier-uri reifier-uri)))))
+ :reifier reifier-topic)))))
(defun from-topic-elem-to-stub-xtm1.0 (topic-elem start-revision
@@ -413,41 +412,22 @@
#'(lambda(member-elem)
(from-member-elem-xtm1.0
member-elem :xtm-id xtm-id))
- (xpath-child-elems-by-qname assoc-elem *xtm1.0-ns* "member"))))
+ (xpath-child-elems-by-qname assoc-elem *xtm1.0-ns* "member")))
+ (reifier-topic (get-reifier-topic-xtm1.0 assoc-elem)))
(unless roles
(error "from-association-elem-xtm1.0: roles are missing in association"))
(setf roles (set-standard-role-types roles))
(unless type
(format t "from-association-elem-xtm1.0: type is missing -> http://www.topicmaps.org/xtm/1.0/core.xtm#association~%")
(setf type (get-item-by-id "association" :xtm-id "core.xtm")))
- (let
- ((association (make-construct 'AssociationC
- :start-revision start-revision
- :instance-of type
- :themes themes
- :roles roles)))
- (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))
- (let ((reifier-uri (getf list-role :reifier-uri)))
- (when (and (stringp reifier-uri)
- (> (length reifier-uri) 0))
- (let ((psi
- (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri
- reifier-uri)))
- (when psi
- (let ((reifier-topic (identified-construct psi)))
- (when reifier-topic
- (add-reifier assoc-role reifier-topic)))))))))
- roles))
- (roles association))
- association))))
+ (add-to-topicmap tm
+ (make-construct 'AssociationC
+ :start-revision start-revision
+ :instance-of type
+ :themes themes
+ :reifier reifier-topic
+ :roles roles)))))
+
(defun set-standard-role-types (roles)
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 Fri Dec 11 19:29:01 2009
@@ -9,12 +9,11 @@
(in-package :xml-importer)
-(defun set-reifier (reifiable-elem reifiable-construct)
- "Sets the reifier-topic of the passed elem to the passed construct."
+(defun get-reifier-topic(reifiable-elem)
+ "Returns the reifier topic of the reifierable-element or nil."
(declare (dom:element reifiable-elem))
- (declare (ReifiableConstructC reifiable-construct))
(let ((reifier-uri (get-attribute reifiable-elem "reifier"))
- (err "From set-reifier(): "))
+ (err "From get-reifier-topic(): "))
(when (and (stringp reifier-uri)
(> (length reifier-uri) 0))
(let ((ii
@@ -22,10 +21,9 @@
(if ii
(let ((reifier-topic (identified-construct ii)))
(if reifier-topic
- (add-reifier reifiable-construct reifier-topic)
+ reifier-topic
(error "~aitem-identifier ~a not found" err reifier-uri)))
- (error "~aitem-identifier ~a not found" err reifier-uri)))))
- reifiable-construct)
+ (error "~aitem-identifier ~a not found" err reifier-uri))))))
(defun from-identifier-elem (classsymbol elem start-revision)
@@ -35,15 +33,10 @@
(declare (symbol classsymbol))
(declare (dom:element elem))
(declare (integer start-revision))
-
-;; (make-construct classsymbol
-;; :uri (get-attribute elem "href")
-;; :start-revision start-revision))
(let
((id (make-instance classsymbol
:uri (get-attribute elem "href")
:start-revision start-revision)))
- ;(add-to-version-history id :start-revision start-revision)
id))
@@ -133,7 +126,8 @@
(instance-of
(from-type-elem (xpath-single-child-elem-by-qname
name-elem
- *xtm2.0-ns* "type") :xtm-id xtm-id)))
+ *xtm2.0-ns* "type") :xtm-id xtm-id))
+ (reifier-topic (get-reifier-topic name-elem)))
(unless namevalue
(error "A name must have exactly one namevalue"))
@@ -143,10 +137,11 @@
:charvalue namevalue
:instance-of instance-of
:item-identifiers item-identifiers
+ :reifier reifier-topic
: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))
- (set-reifier name-elem name))))
+ name)))
(defun from-resourceX-elem (parent-elem)
@@ -195,18 +190,19 @@
(themes (append
(from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") :xtm-id xtm-id)
(themes name)))
- (variant-value (from-resourceX-elem variant-elem)))
+ (variant-value (from-resourceX-elem variant-elem))
+ (reifier-topic (get-reifier-topic variant-elem)))
(unless variant-value
(error "VariantC: one of resourceRef and resourceData must be set"))
- (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))))
+ (make-construct 'VariantC
+ :start-revision start-revision
+ :item-identifiers item-identifiers
+ :themes themes
+ :charvalue (getf variant-value :data)
+ :datatype (getf variant-value :type)
+ :reifier reifier-topic
+ :name name)))
(defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*))
@@ -228,18 +224,19 @@
(from-type-elem (xpath-single-child-elem-by-qname
occ-elem
*xtm2.0-ns* "type") :xtm-id xtm-id))
- (occurrence-value (from-resourceX-elem occ-elem)))
+ (occurrence-value (from-resourceX-elem occ-elem))
+ (reifier-topic (get-reifier-topic occ-elem)))
(unless occurrence-value
(error "OccurrenceC: one of resourceRef and resourceData must be set"))
- (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))))
+ (make-construct 'OccurrenceC
+ :start-revision start-revision
+ :topic top
+ :themes themes
+ :item-identifiers item-identifiers
+ :instance-of instance-of
+ :charvalue (getf occurrence-value :data)
+ :reifier reifier-topic
+ :datatype (getf occurrence-value :type))))
@@ -344,21 +341,14 @@
role-elem
*xtm2.0-ns*
"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"))
+ (reifier-topic (get-reifier-topic role-elem)))
(unless player ;instance-of will be set later - if there is no one
(error "Role in association with topicref ~a not complete" (get-topicref-uri
(xpath-single-child-elem-by-qname
role-elem
*xtm2.0-ns*
"topicRef"))))
- (list :reifier-uri reifier-uri
+ (list :reifier reifier-topic
:instance-of instance-of
:player player
:item-identifiers item-identifiers))))
@@ -375,8 +365,7 @@
(declare (TopicMapC tm))
(elephant:ensure-transaction (:txn-nosync t)
(let
- ((err "From from-association-elem(): ")
- (item-identifiers
+ ((item-identifiers
(make-identifiers 'ItemIdentifierC assoc-elem "itemIdentity" start-revision))
(instance-of
(from-type-elem
@@ -395,40 +384,18 @@
(from-role-elem role-elem start-revision :xtm-id xtm-id))
(xpath-child-elems-by-qname
assoc-elem
- *xtm2.0-ns* "role"))))
+ *xtm2.0-ns* "role")))
+ (reifier-topic (get-reifier-topic assoc-elem)))
(setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them
- (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))
- (let ((reifier-uri (getf list-role :reifier-uri)))
- (when (and (stringp reifier-uri)
- (> (length reifier-uri) 0))
- (let ((ii
- (elephant:get-instance-by-value 'd:ItemIdentifierC 'd:uri
- reifier-uri)))
- (if ii
- (let ((reifier-topic (identified-construct ii)))
- (if reifier-topic
- (add-reifier assoc-role reifier-topic)
- (error "~aitem-identifier ~a not found" err reifier-uri)))
- (error "~aitem-identifier ~a not found" err reifier-uri)))))))
- roles))
- (roles assoc))
- (set-reifier assoc-elem assoc)))))
-
-
+ (add-to-topicmap
+ tm
+ (make-construct 'AssociationC
+ :start-revision start-revision
+ :item-identifiers item-identifiers
+ :instance-of instance-of
+ :themes themes
+ :reifier reifier-topic
+ :roles roles)))))
(defun get-topic-elems (xtm-dom)
(xpath-child-elems-by-qname xtm-dom
More information about the Isidorus-cvs
mailing list