Author: mkuster Date: Sun Feb 1 21:44:18 2009 New Revision: 12 Log: instanceOf associations are now also filtered by TM Added: trunk/src/unit_tests/multiple_tms_ont.xtm trunk/src/unit_tests/multiple_tms_worms.xtm Modified: trunk/src/isidorus.asd trunk/src/model/datamodel.lisp trunk/src/xml/exporter.lisp trunk/src/xml/exporter_xtm1.0.lisp trunk/src/xml/exporter_xtm2.0.lisp Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sun Feb 1 21:44:18 2009 @@ -35,7 +35,8 @@ :depends-on ("importer_xtm2.0" "importer_xtm1.0")) (:file "exporter_xtm1.0") - (:file "exporter_xtm2.0") + (:file "exporter_xtm2.0" + :depends-on ("exporter_xtm1.0")) (:file "exporter" :depends-on ("exporter_xtm1.0" "exporter_xtm2.0"))) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sun Feb 1 21:44:18 2009 @@ -948,6 +948,10 @@ (:method ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'used-as-theme :start-revision revision))) +(defgeneric in-topicmaps (topic) + (:method ((topic TopicC)) + (filter-slot-value-by-revision topic 'in-topicmaps :start-revision *TM-REVISION*))) + (defmethod initialize-instance :around ((instance TopicC) &key (psis nil) (locators nil)) "implement the pseudo-initargs :topic-ids, :persistent-ids, and :subject-locators" (declare (list psis)) @@ -1135,19 +1139,29 @@ (:documentation "Test for the existence of PSIs") (:method ((top TopicC)) (slot-predicate top 'psis))) -(defgeneric list-instanceOf (topic) - (:method ((topic TopicC)))) - -(defmethod list-instanceOf ((topic TopicC)) - (remove-if #'null - (map 'list #'(lambda(x) - (when (loop for psi in (psis (instance-of x)) - when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance") - return t) - (loop for role in (roles (parent x)) - when (not (eq role x)) - return (player role)))) - (player-in-roles topic)))) +(defgeneric list-instanceOf (topic &key tm) + (:documentation "Generate a list of all topics that this topic is an + instance of, optionally filtered by a topic map")) + +(defmethod list-instanceOf ((topic TopicC) &key (tm nil)) + (remove-if + #'null + (map 'list #'(lambda(x) + (when (loop for psi in (psis (instance-of x)) + when (string= (uri psi) "http://psi.topicmaps.org/iso13250/model/instance") + return t) + (loop for role in (roles (parent x)) + when (not (eq role x)) + return (player role)))) + (if tm + (remove-if-not + (lambda (role) + (format t "player: ~a" (player role)) + (format t "parent: ~a" (parent role)) + (format t "topic: ~a~&" topic) + (in-topicmap tm (parent role))) + (player-in-roles topic)) + (player-in-roles topic))))) (defun string-starts-with (str prefix) "Checks if string str starts with a given prefix" Added: trunk/src/unit_tests/multiple_tms_ont.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/multiple_tms_ont.xtm Sun Feb 1 21:44:18 2009 @@ -0,0 +1,57 @@ +<?xml version="1.0" encoding="utf-8"?> +<topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" + xmlns:xlink="http://www.w3.org/1999/xlink"> + <topic id="t1"> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/types/topic-type"/> + </subjectIdentity> + </topic> + + <topic id="a1"> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/types/association-type"/> + </subjectIdentity> + </topic> + + <topic id="r1"> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/types/role-type"/> + </subjectIdentity> + </topic> + + <topic id="t2"> + <instanceOf> + <topicRef xlink:href="#t1"/> + </instanceOf> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/instances/topic-t2"/> + </subjectIdentity> + </topic> + + <topic id="t3"> + <instanceOf> + <topicRef xlink:href="#t1"/> + </instanceOf> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/instances/topic-t3"/> + </subjectIdentity> + </topic> + + <association> + <instanceOf> + <topicRef xlink:href="#a2"/> + </instanceOf> + <member> + <roleSpec> + <topicRef xlink:href="#r1"/> + </roleSpec> + <topicRef xlink:href="#t2"/> + </member> + <member> + <roleSpec> + <topicRef xlink:href="#r1"/> + </roleSpec> + <topicRef xlink:href="#t3"/> + </member> + </association> +</topicMap> \ No newline at end of file Added: trunk/src/unit_tests/multiple_tms_worms.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/multiple_tms_worms.xtm Sun Feb 1 21:44:18 2009 @@ -0,0 +1,16 @@ +<?xml version="1.0" encoding="utf-8"?> +<topicMap xmlns="http://www.topicmaps.org/xtm/1.0/" + xmlns:xlink="http://www.w3.org/1999/xlink"> + + <topic id="t2"> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/instances/topic-t2"/> + </subjectIdentity> + </topic> + + <topic id="t3"> + <subjectIdentity> + <subjectIndicatorRef xlink:href="http://www.egovpt.org/instances/topic-t3"/> + </subjectIdentity> + </topic> +</topicMap> \ No newline at end of file Modified: trunk/src/xml/exporter.lisp ============================================================================== --- trunk/src/xml/exporter.lisp (original) +++ trunk/src/xml/exporter.lisp Sun Feb 1 21:44:18 2009 @@ -1,9 +1,9 @@ (in-package :exporter) -(defun instanceofs-to-elem (ios) - (when ios - (map 'list (lambda (io) (cxml:with-element "t:instanceOf" (ref-to-elem io))) ios))) +;; (defun instanceofs-to-elem (ios) +;; (when ios +;; (map 'list (lambda (io) (cxml:with-element "t:instanceOf" (ref-to-elem io))) ios))) (defun list-extern-associations () @@ -39,15 +39,18 @@ ,@body)))) (defmacro export-to-elem (tm to-elem) - `(map 'list ,to-elem + `(setf *export-tm* ,tm) + `(format t "*export-tm*: ~a" *export-tm*) + `(map 'list + ,to-elem (remove-if #'null (map 'list #'(lambda(top) (d:find-item-by-revision top revision)) (if ,tm - (union - (d:topics ,tm) (d:associations ,tm)) + (union + (d:topics ,tm) (d:associations ,tm)) (union (elephant:get-instances-by-class 'd:TopicC) (list-extern-associations))))))) @@ -60,6 +63,7 @@ ((tm (when tm-id (get-item-by-item-identifier tm-id :revision revision)))) + (setf *export-tm* tm) (with-revision revision (with-open-file (stream xtm-path :direction :output) (cxml:with-xml-output (cxml:make-character-stream-sink stream :canonical nil) Modified: trunk/src/xml/exporter_xtm1.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm1.0.lisp (original) +++ trunk/src/xml/exporter_xtm1.0.lisp Sun Feb 1 21:44:18 2009 @@ -13,6 +13,8 @@ (in-package :exporter) +(defparameter *export-tm* nil "TopicMap which is exported (nil if all is to be exported") + (defgeneric to-elem-xtm1.0 (instance) (:documentation "converts the Topic Maps construct instance to an XTM 1.0 element")) @@ -115,8 +117,8 @@ (baseName | occurrence)* }" (cxml:with-element "t:topic" (cxml:attribute "id" (topicid topic)) - (when (list-instanceOf topic) - (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic))) + (when (list-instanceOf topic :tm *export-tm*) + (map 'list #'to-instanceOf-elem-xtm1.0 (list-instanceOf topic :tm *export-tm*))) (when (or (psis topic) (locators topic)) (to-subjectIdentity-elem-xtm1.0 (psis topic) (first (locators topic)))) (when (names topic) Modified: trunk/src/xml/exporter_xtm2.0.lisp ============================================================================== --- trunk/src/xml/exporter_xtm2.0.lisp (original) +++ trunk/src/xml/exporter_xtm2.0.lisp Sun Feb 1 21:44:18 2009 @@ -118,9 +118,9 @@ (map 'list #'to-elem (item-identifiers topic)) (map 'list #'to-elem (locators topic)) (map 'list #'to-elem (psis topic)) - (when (list-instanceOf topic) + (when (list-instanceOf topic :tm *export-tm*) (cxml:with-element "t:instanceOf" - (loop for item in (list-instanceOf topic) + (loop for item in (list-instanceOf topic :tm *export-tm*) do (cxml:with-element "t:topicRef" (cxml:attribute "href" (concatenate 'string "#" (topicid item))))))) (map 'list #'to-elem (names topic))