[isidorus-cvs] r12 - in trunk/src: . model unit_tests xml

Marc Wilhelm Kuster mkuster at common-lisp.net
Sun Feb 1 21:44:18 UTC 2009


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 @@
              , at 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))




More information about the Isidorus-cvs mailing list