[isidorus-cvs] r125 - in trunk/src: . unit_tests xml/rdf

Lukas Giessmann lgiessmann at common-lisp.net
Mon Aug 31 15:30:18 UTC 2009


Author: lgiessmann
Date: Mon Aug 31 11:30:16 2009
New Revision: 125

Log:
rdf-importer: added some helper functions to be able to recognize constructs that were imported by isidorus, e.g. isidorus:name, etc.

Modified:
   trunk/src/constants.lisp
   trunk/src/unit_tests/rdf_importer_test.lisp
   trunk/src/xml/rdf/importer.lisp
   trunk/src/xml/rdf/rdf_tools.lisp

Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp	(original)
+++ trunk/src/constants.lisp	Mon Aug 31 11:30:16 2009
@@ -39,7 +39,19 @@
 	   :*rdf2tm-object*
 	   :*rdf2tm-subject*
 	   :*rdf2tm-scope-prefix*
-	   :*tm2rdf-ns*))
+	   :*tm2rdf-ns*
+	   :*tm2rdf-topic-type-uri*
+	   :*tm2rdf-name-type-uri*
+	   :*tm2rdf-name-property*
+	   :*tm2rdf-variant-type-uri*
+	   :*tm2rdf-variant-property*
+	   :*tm2rdf-occurrence-type-uri*
+	   :*tm2rdf-occurrence-property*
+	   :*tm2rdf-role-type-uri*
+	   :*tm2rdf-role-property*
+	   :*tm2rdf-association-type-uri*
+	   :*tm2rdf-associaiton-property*))
+	   
 
 (in-package :constants)
 (defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/")
@@ -80,24 +92,46 @@
 
 (defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/")
 
-(defparameter *rdf-statement* "http://www.w3.org/1999/02/22-rdf-syntax-ns#Statement")
+(defparameter *rdf-statement* (concatenate 'string *rdf-ns* "Statement"))
 
-(defparameter *rdf-object* "http://www.w3.org/1999/02/22-rdf-syntax-ns#object")
+(defparameter *rdf-object* (concatenate 'string *rdf-ns* "object"))
 
-(defparameter *rdf-subject* "http://www.w3.org/1999/02/22-rdf-syntax-ns#subject")
+(defparameter *rdf-subject* (concatenate 'string *rdf-ns* "subject"))
 
-(defparameter *rdf-predicate* "http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate")
+(defparameter *rdf-predicate* (concatenate 'string *rdf-ns* "predicate"))
 
-(defparameter *rdf-nil* "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")
+(defparameter *rdf-nil* (concatenate 'string *rdf-ns* "nil"))
 
-(defparameter *rdf-first* "http://www.w3.org/1999/02/22-rdf-syntax-ns#first")
+(defparameter *rdf-first* (concatenate 'string *rdf-ns* "first"))
 
-(defparameter *rdf-rest* "http://www.w3.org/1999/02/22-rdf-syntax-ns#rest")
+(defparameter *rdf-rest* (concatenate 'string *rdf-ns* "rest"))
 
-(defparameter *rdf2tm-object* "http://isidorus/rdf2tm_mapping/object")
+(defparameter *rdf2tm-object* (concatenate 'string *rdf2tm-ns* "object"))
 
-(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping/subject")
+(defparameter *rdf2tm-subject* (concatenate 'string *rdf2tm-ns* "subject"))
 
-(defparameter *rdf2tm-scope-prefix* "http://isidorus/rdf2tm_mapping/scope/")
+(defparameter *rdf2tm-scope-prefix* (concatenate 'string *rdf2tm-ns* "scope/"))
 
-(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
\ No newline at end of file
+(defparameter *tm2rdf-ns* "http://isidorus/tm2rdf_mapping/")
+
+(defparameter *tm2rdf-topic-type-uri* (concatenate 'string *tm2rdf-ns* "Topic"))
+
+(defparameter *tm2rdf-name-type-uri* (concatenate 'string *tm2rdf-ns* "Name"))
+
+(defparameter *tm2rdf-name-property* (concatenate 'string *tm2rdf-ns* "name"))
+
+(defparameter *tm2rdf-variant-type-uri* (concatenate 'string *tm2rdf-ns* "Variant"))
+
+(defparameter *tm2rdf-variant-property* (concatenate 'string *tm2rdf-ns* "variant"))
+
+(defparameter *tm2rdf-occurrence-type-uri* (concatenate 'string *tm2rdf-ns* "Occurrence"))
+
+(defparameter *tm2rdf-occurrence-property* (concatenate 'string *tm2rdf-ns* "occurrence"))
+
+(defparameter *tm2rdf-role-type-uri* (concatenate 'string *tm2rdf-ns* "Role"))
+
+(defparameter *tm2rdf-role-property* (concatenate 'string *tm2rdf-ns* "role"))
+
+(defparameter *tm2rdf-association-type-uri* (concatenate 'string *tm2rdf-ns* "Association"))
+
+(defparameter *tm2rdf-association-property* (concatenate 'string *tm2rdf-ns* "association"))

Modified: trunk/src/unit_tests/rdf_importer_test.lisp
==============================================================================
--- trunk/src/unit_tests/rdf_importer_test.lisp	(original)
+++ trunk/src/unit_tests/rdf_importer_test.lisp	Mon Aug 31 11:30:16 2009
@@ -18,6 +18,7 @@
                 *rdf-ns*
 		*rdfs-ns*
 		*rdf2tm-ns*
+		*tm2rdf-ns*
 		*xml-ns*
 		*xml-string*
 		*instance-psi*
@@ -32,7 +33,13 @@
 		*rdf-subject*
 		*rdf-object*
 		*rdf-predicate*
-		*rdf-statement*)
+		*rdf-statement*
+		*tm2rdf-topic-type-uri*
+		*tm2rdf-name-type-uri*
+		*tm2rdf-variant-type-uri*
+		*tm2rdf-occurrence-type-uri*
+		*tm2rdf-role-type-uri*
+		*tm2rdf-association-type-uri*)
   (:import-from :xml-tools
                 xpath-child-elems-by-qname
 		xpath-single-child-elem-by-qname
@@ -59,7 +66,10 @@
 	   :test-poems-rdf-topics
 	   :test-empty-collection
 	   :test-collection
-	   :test-xml-base))
+	   :test-xml-base
+	   :test-get-type-psis
+	   :test-get-all-type-psis
+	   :test-isidorus-type-p))
 
 (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
 
@@ -3054,7 +3064,200 @@
 		       "http://base-3/test")))))))
 
 
+(test test-get-type-psis
+  "Tests the function get-type-psis."
+  (let ((tm-id "http://test-tm/")
+	(doc-1
+	 (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+		      "xmlns:sw=\"http://test/arcs/\">"
+		      " <sw:Node rdf:about=\"http://sw/node\""
+		      "          rdf:type=\"http://sw/Node-1\">"
+		      "  <sw:type rdf:resource=\"anyResource\"/>"
+		      "  <rdf:type rdf:resource=\"Node-2\"/>"
+		      "  <rdf:type rdf:resource=\"http://sw/Node-3\"/>"
+		      "  <rdf:type rdf:nodeID=\"anyType\"/>"
+		      " </sw:Node>"
+
+		      " <rdf:Description rdf:about=\"http://sw/emtpy\"/>"
+		      "</rdf:RDF>")))
+    (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+      (let ((rdf-node (elt (dom:child-nodes dom-1) 0)))
+	(is (= (length (rdf-importer::child-nodes-or-text rdf-node)) 2))
+	(let ((resource-1 
+	       (elt (rdf-importer::child-nodes-or-text rdf-node) 0))
+	      (resource-2 
+	       (elt (rdf-importer::child-nodes-or-text rdf-node) 1))
+	      (types (list "http://test/arcs/Node" "http://sw/Node-1"
+			   "http://xml-base/Node-2" "http://sw/Node-3"))
+	      (types-2 (list "http://test/arcs/Node" "http://sw/Node-1"
+			     (concatenate 'string tm-id "Node-2")
+			     "http://sw/Node-3")))
+	  (is-true resource-1)
+	  (is-true resource-2)
+	  (is (= (length
+		  (intersection
+		   types
+		   (rdf-importer::get-type-psis
+		    resource-1 tm-id
+		    :parent-xml-base "http://xml-base/")
+		   :test #'string=))
+		 (length types)))
+	  (is (= (length
+		  (intersection
+		   types-2
+		   (rdf-importer::get-type-psis resource-1 tm-id)
+		   :test #'string=))
+		 (length types-2)))
+	  (is-false (rdf-importer::get-type-psis
+		     resource-2 tm-id
+		     :parent-xml-base "http://xml-base/")))))))
+
+
+(test test-get-all-type-psis
+  "Tests the functions get-all-type-psis, get-type-psis-across-dom and
+   get-type-psis."
+  (let ((tm-id "http://test-tm/")
+	(doc-1
+	 (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+		      "xmlns:sw=\"http://test/arcs/\">"
+		      " <rdf:Description rdf:nodeID=\"anyNode\">"
+		      "  <rdf:type rdf:resource=\"http://type-1\"/>"
+		      "  <sw:arc>"
+		      "   <rdf:Description rdf:nodeID=\"anyNode\" "
+		      "                   rdf:type=\"http://type-2\"/>"
+		      "  </sw:arc>"
+		      " </rdf:Description>"
+
+		      " <rdf:Description rdf:nodeID=\"anotherNode\">"
+		      "  <rdf:type rdf:resource=\"http://type-3\"/>"
+		      " </rdf:Description>"
+
+		      " <sw:NodeType rdf:nodeID=\"anyNode\"/>"
+
+		      " <rdf:Description rdf:nodeID=\"anyNode\" "
+		      "                  rdf:datatype=\"anyDatatype\">"
+		      "  <rdf:type rdf:resource=\"http://type-7\"/>"
+		      " </rdf:Description>"
+
+		      " <rdf:Description rdf:about=\"http://a-node\">"
+		      "  <sw:arc>"
+		      "   <rdf:Description rdf:about=\"http://b-node\">"
+		      "   <rdf:type rdf:resource=\"http://type-5\"/>"
+		      "    <rdf:arc>"
+		      "     <rdf:Description rdf:nodeID=\"anyNode\">"
+		      "      <rdf:type rdf:resource=\"http://type-5\"/>"
+		      "      <rdf:type rdf:resource=\"http://type-6\"/>"
+		      "     </rdf:Description>"
+		      "    </rdf:arc>"
+		      "   </rdf:Description>"
+		      "  </sw:arc>"
+		      " </rdf:Description>"
+		      "</rdf:RDF>")))
+    (let ((root (elt (dom:child-nodes (cxml:parse doc-1
+						  (cxml-dom:make-dom-builder)))
+		     0)))
+      (is (= (length (rdf-importer::child-nodes-or-text root)) 5))
+      (let ((any-node-1 (elt (rdf-importer::child-nodes-or-text root) 0))
+	    (another-node (elt (rdf-importer::child-nodes-or-text root) 1))
+	    (fn-types (list "http://type-1" "http://type-2"
+			    "http://test/arcs/NodeType" "http://type-5"
+			    "http://type-6"))
+	    (any-node-4 (elt (rdf-importer::child-nodes-or-text root) 3)))
+	(let ((types-1 (rdf-importer::get-all-type-psis any-node-1 tm-id))
+	      (types-4 (rdf-importer::get-all-type-psis any-node-4 tm-id))
+	      (types-another-node (rdf-importer::get-all-type-psis
+				   another-node tm-id)))
+	  (is (= (length (intersection fn-types types-1 :test #'string=))
+		 (length fn-types)))
+	  (is (= (length types-another-node) 1))
+	  (is (string= "http://type-3"
+		       (first types-another-node)))
+	  (is (= (length (intersection fn-types types-4 :test #'string=))
+		 (length fn-types))))))))
+
+
+(test test-isidorus-type-p
+  "Tests the function isidorus-type-p."
+    (let ((tm-id "http://test-tm/")
+	(doc-1
+	 (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+		      "xmlns:sw=\"http://test/arcs/\" "
+		      "xmlns:isi=\"" *tm2rdf-ns* "\">"
+		      " <isi:Topic rdf:about=\"http://node-1\">"
+		      "  <isi:name>"
+		      "   <rdf:Description rdf:nodeID=\"name-id\"/>"
+		      "  </isi:name>"
+		      "  <isi:occurrence rdf:nodeID=\"occurrence-id\"/>"
+		      "  <isi:occurrence>"
+		      "   <rdf:Description>"
+		      "    <rdf:type rdf:resource=\""
+		                          *tm2rdf-occurrence-type-uri* "\"/>"
+		      "   </rdf:Description>"
+		      "  </isi:occurrence>"
+		      " </isi:Topic>"
+
+		      " <rdf:Description rdf:nodeID=\"name-id\">"
+		      "  <rdf:type rdf:resource=\"" *tm2rdf-name-type-uri*"\"/>"
+		      "  <isi:variant>"
+		      "   <isi:Variant rdf:nodeID=\"variant-id\"/>"
+		      "  </isi:variant>"
+		      " </rdf:Description>"
+
+		      " <isi:Occurrence rdf:nodeID=\"occurrence-id\"/>"
+
+		      " <rdf:Description rdf:nodeID=\"association-id\">"
+		      "  <rdf:type rdf:resource=\""
+		                      *tm2rdf-association-type-uri* "\"/>"
+		      "  <isi:role>"
+		      "   <isi:Role rdf:nodeID=\"role-id\"/>"
+                      "  </isi:role>"
+		      " </rdf:Description>"
+		      "</rdf:RDF>")))
+    (let ((root (elt (dom:child-nodes (cxml:parse doc-1
+						  (cxml-dom:make-dom-builder)))
+		     0)))
+      (is (= (length (rdf-importer::child-nodes-or-text root)) 4))
+      (let ((topic-node (elt (rdf-importer::child-nodes-or-text root) 0))
+	    (association-node (elt (rdf-importer::child-nodes-or-text root) 3)))
+	(let ((topic-name (elt (rdf-importer::child-nodes-or-text topic-node) 
+			       0))
+	      (topic-occurrence-1 (elt (rdf-importer::child-nodes-or-text
+					topic-node)
+				       1))
+	      (topic-occurrence-2 (elt (rdf-importer::child-nodes-or-text
+					topic-node)
+				       2))
+	      (association-role (elt (rdf-importer::child-nodes-or-text
+				      association-node)
+				     1))
+	      (name-variant (elt (rdf-importer::child-nodes-or-text
+				  (elt (rdf-importer::child-nodes-or-text root)
+				       1))
+				 1)))
+	  (is-true (rdf-importer::isidorus-type-p topic-node tm-id 
+						  'rdf-importer::topic))
+	  (is-true (rdf-importer::isidorus-type-p association-node tm-id
+						  'rdf-importer::association))
+	  (is-true (rdf-importer::isidorus-type-p topic-name tm-id
+						  'rdf-importer::name))
+	  (is-true (rdf-importer::isidorus-type-p name-variant tm-id
+						  'rdf-importer::variant))
+	  (is-true (rdf-importer::isidorus-type-p topic-occurrence-1 tm-id
+						  'rdf-importer::occurrence))
+	  (is-true (rdf-importer::isidorus-type-p topic-occurrence-2 tm-id
+						  'rdf-importer::occurrence))
+	  (is-true (rdf-importer::isidorus-type-p association-role tm-id
+						  'rdf-importer::role))
+	  (is-false (rdf-importer::isidorus-type-p
+		     (elt (rdf-importer::child-nodes-or-text root) 1) tm-id
+		     'rdf-importer::name))
+	  (is-false (rdf-importer::isidorus-type-p
+		     (elt (rdf-importer::child-nodes-or-text root) 2) tm-id
+		     'rdf-importer::occurrence)))))))
+
+
 (defun run-rdf-importer-tests()
+  "Runs all defined tests."
   (when elephant:*store-controller*
     (elephant:close-store))
   (it.bese.fiveam:run! 'test-get-literals-of-node)
@@ -3075,4 +3278,7 @@
   (it.bese.fiveam:run! 'test-poems-rdf-topics)
   (it.bese.fiveam:run! 'test-empty-collection)
   (it.bese.fiveam:run! 'test-collection)
-  (it.bese.fiveam:run! 'test-xml-base))
\ No newline at end of file
+  (it.bese.fiveam:run! 'test-xml-base)
+  (it.bese.fiveam:run! 'test-get-type-psis)
+  (it.bese.fiveam:run! 'test-get-all-type-psis)
+  (it.bese.fiveam:run! 'test-isidorus-type-p))
\ No newline at end of file

Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp	(original)
+++ trunk/src/xml/rdf/importer.lisp	Mon Aug 31 11:30:16 2009
@@ -96,8 +96,7 @@
   (format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove
   (tm-id-p tm-id "import-node")
   (parse-node elem)
-  (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
-	(fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
+  (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
     (let ((about (get-absolute-attribute elem tm-id xml-base "about"))	   
 	  (nodeID (get-ns-attribute elem "nodeID"))
 	  (ID (get-absolute-attribute elem tm-id xml-base "ID"))
@@ -108,16 +107,7 @@
 			    (get-literals-of-node-content
 			     elem tm-id xml-base fn-xml-lang)))
 	  (associations (get-associations-of-node-content elem tm-id xml-base))
-	  (types (remove-if
-		  #'null
-		  (append (list
-			   (unless (string= (get-type-of-node-name elem)
-					    (concatenate 'string *rdf-ns*
-							 "Description"))
-			     (list :topicid (get-type-of-node-name elem)
-				   :psi (get-type-of-node-name elem)
-				   :ID nil)))
-			  (get-types-of-node-content elem tm-id fn-xml-base))))
+	  (types (get-types-of-node elem tm-id :parent-xml-base xml-base))
 	  (super-classes
 	   (get-super-classes-of-node-content elem tm-id xml-base)))
       (with-tm (start-revision document-id tm-id)

Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp	(original)
+++ trunk/src/xml/rdf/rdf_tools.lisp	Mon Aug 31 11:30:16 2009
@@ -31,7 +31,18 @@
 		*rdf-nil*
 		*rdf-first*
 		*rdf-rest*
-		*rdf2tm-scope-prefix*)
+		*rdf2tm-scope-prefix*
+		*tm2rdf-topic-type-uri*
+		*tm2rdf-name-type-uri*
+		*tm2rdf-name-property*
+		*tm2rdf-variant-type-uri*
+		*tm2rdf-variant-property*
+		*tm2rdf-occurrence-type-uri*
+		*tm2rdf-occurrence-property*
+		*tm2rdf-role-type-uri*
+		*tm2rdf-role-property*
+		*tm2rdf-association-type-uri*
+		*tm2rdf-association-property*)
   (:import-from :xml-constants
 		*rdf_core_psis.xtm*
 		*core_psis.xtm*)
@@ -369,8 +380,7 @@
 	     datatype))
     (when (and (or nodeID resource)
 	       (> (length content) 0))
-      ;(set-_n-name property _n-counter)))
-      (error "~awhen ~a is set no content is allowed: ~a!"
+     (error "~awhen ~a is set no content is allowed: ~a!"
 	     err-pref
 	     (cond
 	       (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
@@ -469,4 +479,187 @@
   "Checks the validity of the passed tm-id."
   (unless (absolute-uri-p tm-id)
     (error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!"
-	   fun-name tm-id)))
\ No newline at end of file
+	   fun-name tm-id)))
+
+
+(defun get-types-of-node (elem tm-id &key (parent-xml-base nil))
+  "Returns a plist of all node's types of the form
+   (:topicid <string> :psi <string> :ID <string>)."
+  (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+    (remove-if
+     #'null
+     (append (unless (string= (get-type-of-node-name elem)
+			      (concatenate 'string *rdf-ns*
+					   "Description"))
+	       (list 
+		(list :topicid (get-type-of-node-name elem)
+		      :psi (get-type-of-node-name elem)
+		      :ID nil)))
+	     (get-types-of-node-content elem tm-id xml-base)))))
+
+
+(defun get-type-psis (elem tm-id
+		      &key (parent-xml-base nil))
+  "Returns a list of type-uris of the passed node."
+  (let ((types (get-types-of-node elem tm-id
+				  :parent-xml-base parent-xml-base)))
+    (remove-if #'null
+	       (map 'list #'(lambda(x)
+			      (getf x :psi))
+		    types))))
+
+
+(defun get-all-type-psis-of-id (nodeID tm-id document)
+  "Returns a list of type-uris for resources identified by the given
+   nodeID by analysing the complete XML-DOM."
+  (let ((root (elt (dom:child-nodes document) 0)))
+    (remove-duplicates
+     (remove-if #'null
+		(if (and (string= (dom:namespace-uri root) *rdf-ns*)
+			 (string= (get-node-name root)"RDF"))
+		    (loop for node across (child-nodes-or-text root)
+		       append (get-all-type-psis-across-dom
+			       root tm-id :resource-id nodeID))
+		    (get-all-type-psis-across-dom
+		     root tm-id :resource-id nodeID)))
+     :test #'string=)))
+
+
+(defun get-all-type-psis (elem tm-id &key (parent-xml-base nil))
+  "Returns a list of type-uris for the element by analysing the complete
+   XML-DOM."
+  (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+    (let ((root (elt (dom:child-nodes (dom:owner-document elem)) 0))
+	  (nodeID (get-ns-attribute elem "nodeID"))
+	  (about (get-absolute-attribute elem tm-id xml-base "about")))
+      (remove-duplicates
+       (remove-if #'null
+		  (if (or nodeID about)
+		      (if (and (string= (dom:namespace-uri root) *rdf-ns*)
+			       (string= (get-node-name root) "RDF"))
+			  (loop for node across (child-nodes-or-text root)
+			     append (get-all-type-psis-across-dom
+				     root tm-id :resource-uri about
+				     :resource-id nodeID))
+			  (get-all-type-psis-across-dom
+			   root tm-id :resource-uri about
+			   :resource-id nodeID))
+		      (get-type-psis elem tm-id :parent-xml-base parent-xml-base)))
+       :test #'string=))))
+
+
+(defun get-all-type-psis-across-dom (elem tm-id &key (parent-xml-base nil)
+				     (resource-uri nil) (resource-id nil)
+				     (types nil))
+  "Returns a list of type PSI strings collected over the complete XML-DOM
+   corresponding to the passed id's or uri."
+  (when (or resource-uri resource-id)
+    (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+      (let ((datatype (when (get-ns-attribute elem "datatype")
+			t))
+	    (parseType (when (get-ns-attribute elem "parseType")
+			 (string= (get-ns-attribute elem "parseType")
+				  "Literal"))))
+	(if (or datatype parseType)
+	    types
+	    (let ((nodeID (get-ns-attribute elem "nodeID"))
+		  (about (get-absolute-attribute elem tm-id xml-base "about")))
+	      (let ((fn-types
+		     (append types
+			     (when (or (and about resource-uri
+					    (string= about resource-uri))
+				       (and nodeID resource-id
+					    (string= nodeID resource-id)))
+			       (get-type-psis elem tm-id
+					      :parent-xml-base xml-base))))
+		    (content (child-nodes-or-text elem :trim t)))
+		(if (or (stringp content)
+			(not content))
+		    fn-types
+		    (loop for child-node across content
+		       append (get-all-type-psis-across-dom
+			       child-node tm-id :parent-xml-base xml-base
+			       :resource-uri resource-uri
+			       :resource-id resource-id
+			       :types fn-types))))))))))
+
+
+(defun type-p (elem type-uri tm-id &key (parent-xml-base nil))
+  "Returns t if the type-uri is a type of elem."
+  (declare (string tm-id type-uri))
+  (declare (dom:element elem))
+  (tm-id-p tm-id "type-p")
+  (find type-uri (get-all-type-psis elem tm-id
+				    :parent-xml-base parent-xml-base)
+	:test #'string=))
+
+
+(defun type-of-id-p (node-id type-uri tm-id document)
+  "Returns t if type-uri is a type of the passed node-id."
+  (declare (string node-id type-uri tm-id))
+  (declare (dom:document document))
+  (tm-id-p tm-id "type-of-ndoe-id-p")
+  (find type-uri (get-all-type-psis-of-id node-id tm-id document)
+	:test #'string=))
+
+
+(defun property-name-of-node-p (elem property-name-uri)
+  "Returns t if the elements tag-name and namespace are equal
+   to the given uri."
+  (declare (dom:element elem))
+  (declare (string property-name-uri))
+  (when property-name-uri
+    (let ((uri (concatenate-uri (dom:namespace-uri elem)
+				(get-node-name elem))))
+      (string= uri property-name-uri))))
+
+
+(defun isidorus-type-p (property-elem-or-node-elem tm-id what
+			&key(parent-xml-base nil))
+  "Returns t if the node elem is of the type isidorus:<Type> and is
+   contained in a porperty isidorus:<type>."
+  (declare (dom:element property-elem-or-node-elem))
+  (declare (symbol what))
+  (tm-id-p tm-id "isidorus-type-p")
+  (let ((xml-base (get-xml-base property-elem-or-node-elem
+				:old-base parent-xml-base))
+	(type-and-property (cond
+			     ((eql what 'name)
+			      (list :type *tm2rdf-name-type-uri*
+				    :property *tm2rdf-name-property*))
+			     ((eql what 'variant)
+			      (list :type *tm2rdf-variant-type-uri*
+				    :property *tm2rdf-variant-property*))
+			     ((eql what 'occurrence)
+			      (list :type *tm2rdf-occurrence-type-uri*
+				    :property *tm2rdf-occurrence-property*))
+			     ((eql what 'role)
+			      (list :type *tm2rdf-role-type-uri*
+				    :property *tm2rdf-role-property*))
+			     ((eql what 'topic)
+			      (list :type *tm2rdf-topic-type-uri*))
+			     ((eql what 'association)
+			      (list :type 
+				    *tm2rdf-association-type-uri*)))))
+    (when type-and-property
+      (let ((type (getf type-and-property :type))
+	    (property (getf type-and-property :property))
+	    (nodeID (get-ns-attribute property-elem-or-node-elem "nodeID"))
+	    (document (dom:owner-document property-elem-or-node-elem))
+	    (elem-uri (concatenate-uri
+		       (dom:namespace-uri
+			property-elem-or-node-elem)
+		       (get-node-name property-elem-or-node-elem))))
+	(if (or (string= type *tm2rdf-topic-type-uri*)
+		(string= type *tm2rdf-association-type-uri*))
+	    (type-p property-elem-or-node-elem type tm-id
+		    :parent-xml-base parent-xml-base)
+	    (when (string= elem-uri property)
+	      (if nodeID
+		  (type-of-id-p nodeId type tm-id document)
+		  (let ((content (child-nodes-or-text  property-elem-or-node-elem
+						       :trim t)))
+		    (when (and (= (length content) 1)
+			       (not (stringp content)))
+		      (type-p (elt content 0) type tm-id
+			      :parent-xml-base xml-base))))))))))
\ No newline at end of file




More information about the Isidorus-cvs mailing list