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

Lukas Giessmann lgiessmann at common-lisp.net
Thu Aug 13 19:47:54 UTC 2009


Author: lgiessmann
Date: Thu Aug 13 15:47:53 2009
New Revision: 113

Log:
rdf-importer: finalized the rdf-importer -> collections are imported as linked lists modelled as tm-associations (equal to manual created rdf-collections

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

Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp	(original)
+++ trunk/src/constants.lisp	Thu Aug 13 15:47:53 2009
@@ -37,7 +37,6 @@
 	   :*rdf-rest*
 	   :*rdf2tm-object*
 	   :*rdf2tm-subject*
-	   :*rdf2tm-collection*
 	   :*rdf2tm-scope-prefix*))
 
 (in-package :constants)
@@ -95,6 +94,4 @@
 
 (defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping#subject")
 
-(defparameter *rdf2tm-collection* "http://isidorus/rdf2tm_mapping#collection")
-
 (defparameter *rdf2tm-scope-prefix* "http://isidorus/rdf2tm_mapping/scope#")
\ No newline at end of file

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	Thu Aug 13 15:47:53 2009
@@ -57,7 +57,9 @@
 	   :test-poems-rdf-occurrences
 	   :test-poems-rdf-associations
 	   :test-poems-rdf-typing
-	   :test-poems-rdf-topics))
+	   :test-poems-rdf-topics
+	   :test-empty-collection
+	   :test-collection))
 
 (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
 
@@ -1034,7 +1036,7 @@
 	  (rdf-init-db :db-dir db-dir :start-revision revision-1)
 	  (rdf-importer::import-node node tm-id revision-2
 				     :document-id document-id)
-	  (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 21))
+	  (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20))
 	  (let ((first-node (get-item-by-id "http://test-tm/first-node"
 					    :xtm-id document-id))
 		(first-type (get-item-by-id "http://test-tm/first-type"
@@ -1472,8 +1474,8 @@
 		   2))
 	    (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
 				      :document-id document-id)
-	    (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 38))
-	    (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 10))
+	    (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 40))
+	    (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 12))
 	    (setf rdf-importer::*current-xtm* document-id)
 	    (is (= (length
 		    (intersection
@@ -1482,7 +1484,7 @@
 		     (list
 		      (d:get-item-by-id (concatenate
 					 'string
-					 constants::*rdf2tm-collection*)
+					 constants::*rdf-nil*)
 					:xtm-id rdf-importer::*rdf-core-xtm*)
 		      (d:get-item-by-psi constants::*type-instance-psi*)
 		      (dotimes (iter 9)
@@ -1515,8 +1517,9 @@
 				  constants:*type-instance-psi*))
 		  (subject (d:get-item-by-psi constants::*rdf2tm-subject*))
 		  (object (d:get-item-by-psi constants::*rdf2tm-object*))
-		  (collection (d:get-item-by-id
-			       constants::*rdf2tm-collection*)))
+		  (rdf-first (d:get-item-by-psi constants:*rdf-first*))
+		  (rdf-rest (d:get-item-by-psi constants:*rdf-rest*))
+		  (rdf-nil (d:get-item-by-psi constants:*rdf-nil*)))
 	      (is (= (length (d:psis first-node)) 1))
 	      (is (string= (d:uri (first (d:psis first-node)))
 			   "http://test-tm/first-node"))
@@ -1560,6 +1563,15 @@
 	      (is (= (length (d:psis arc8)) 1))
 	      (is (string= (d:uri (first (d:psis arc8)))
 			   "http://test/arcs/arc8"))
+	      (is (= (length (d:psis rdf-first)) 1))
+	      (is (string= (d:uri (first (d:psis rdf-first)))
+			   constants:*rdf-first*))
+	      (is (= (length (d:psis rdf-rest)) 1))
+	      (is (string= (d:uri (first (d:psis rdf-rest)))
+			   constants:*rdf-rest*))
+	      (is (= (length (d:psis rdf-nil)) 1))
+	      (is (string= (d:uri (first (d:psis rdf-nil)))
+			   constants:*rdf-nil*))
 	      (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC))
 		     1))
 	      (is (string= (d:charvalue (first (elephant:get-instances-by-class
@@ -1629,30 +1641,84 @@
 				     (eql (d:instance-of (d:parent x)) arc4)))
 			    (d:player-in-roles uuid-1))))))))
 		  (is-true col-1)
-		  (is (= (length (d:player-in-roles col-1)) 2))
+		  (is (= (length (d:player-in-roles col-1)) 3))
 		  (is-true (find-if
 			    #'(lambda(x)
 				(and (eql (d:instance-of x) subject)
 				     (eql (d:instance-of (d:parent x)) 
-					  collection)))
+					  rdf-first)))
 			    (d:player-in-roles col-1)))
-		  (let ((col-assoc
-			 (d:parent
-			  (find-if
+		  (is-true (find-if
 			    #'(lambda(x)
 				(and (eql (d:instance-of x) subject)
 				     (eql (d:instance-of (d:parent x)) 
-					  collection)))
-			    (d:player-in-roles col-1)))))
-		    (is-true col-assoc)
-		    (is (= (length (d:roles col-assoc)) 3))
-		    (is (= (count-if
+					  rdf-rest)))
+			    (d:player-in-roles col-1)))
+		  (is-true (find-if
+			    #'(lambda(x)
+				(and (eql (d:instance-of x) object)
+				     (eql (d:instance-of (d:parent x)) 
+					  arc4)))
+			    (d:player-in-roles col-1)))
+		  (is (= (length (d:player-in-roles item-1)) 1))
+		  (is-true (find-if
 			    #'(lambda(x)
 				(and (eql (d:instance-of x) object)
-				     (or (eql (d:player x) item-1)
-					 (eql (d:player x) item-2))))
-			    (d:roles col-assoc))
-			   2))))
+				     (eql (d:instance-of (d:parent x)) 
+					  rdf-first)))
+			    (d:player-in-roles item-1)))
+		  (let ((col-2
+			 (let ((role
+				(find-if
+				 #'(lambda(x)
+				     (and (eql (d:instance-of x) subject)
+					  (eql (d:instance-of (d:parent x)) 
+					       rdf-rest)))
+				 (d:player-in-roles col-1))))
+			   (is (= (length (d:roles (d:parent role))) 2))
+			   (let ((other-role
+				  (find-if #'(lambda(x)
+					       (and (not (eql x role))
+						    (eql (d:instance-of x)
+							 object)))
+					   (d:roles (d:parent role)))))
+			     (d:player other-role)))))
+		    (is-true col-2)
+		    (is (= (length (d:psis col-2)) 0))
+		    (is (= (length (d:player-in-roles col-2)) 3))
+		    (is-true (find-if
+			      #'(lambda(x)
+				  (and (eql (d:instance-of x) subject)
+				       (eql (d:instance-of (d:parent x))
+					    rdf-first)))
+			      (d:player-in-roles col-2)))
+		    (is-true (find-if
+			      #'(lambda(x)
+				  (and (eql (d:instance-of x) subject)
+				       (eql (d:instance-of (d:parent x))
+					    rdf-rest)))
+			      (d:player-in-roles col-2)))
+		    (let ((col-3
+			   (let ((role
+				  (find-if
+				   #'(lambda(x)
+				       (and (eql (d:instance-of x) subject)
+					    (eql (d:instance-of (d:parent x))
+						 rdf-rest)))
+				   (d:player-in-roles col-2))))
+
+			     (is (= (length (d:roles (d:parent role))) 2))
+			     (let ((other-role
+				    (find-if
+				     #'(lambda(x)
+					 (not (eql x role)))
+				     (d:roles (d:parent role)))))
+			       (d:player other-role)))))
+		      (is-true col-3)
+		      (is (= (length (d:psis col-3)) 1))
+		      (is (string= (d:uri (first (d:psis col-3)))
+				   constants:*rdf-nil*))
+		      (is (= (length (d:player-in-roles col-3)) 2)))))
 		(is (= (length (d:player-in-roles item-1)) 1))
 		(is (= (length (d:player-in-roles item-2)) 2))
 		(is-true (find-if
@@ -1689,12 +1755,13 @@
 			 4))
 		  (is (= (length (d:player-in-roles fourth-node)) 1))
 		  (is (= (length (d:player-in-roles fifth-node)) 1))
+		  (format t "--->")
 		  (let ((col-2
 			 (d:player
 			  (find-if
 			   #'(lambda(y)
 			       (and (eql (d:instance-of y) object)
-				    (= 0 (length (d:psis (d:player y))))))
+				    (= 1 (length (d:psis (d:player y))))))
 			   (d:roles
 			    (d:parent
 			     (find-if
@@ -1702,24 +1769,11 @@
 				  (and (eql (d:instance-of x) subject)
 				       (eql (d:instance-of (d:parent x)) arc8)))
 			      (d:player-in-roles uuid-2))))))))
+		    (is (= (length (d:psis col-2)) 1))
+		    (is (string= constants:*rdf-nil*
+				 (d:uri (first (d:psis col-2)))))
 		    (is-true col-2)
-		    (is (= (length (d:player-in-roles col-2)) 2))
-		    (is-true (find-if
-			      #'(lambda(x)
-				  (and (eql (d:instance-of x) subject)
-				       (eql (d:instance-of (d:parent x)) 
-					    collection)))
-			      (d:player-in-roles col-2)))
-		    (let ((col-assoc
-			   (d:parent
-			    (find-if
-			     #'(lambda(x)
-				 (and (eql (d:instance-of x) subject)
-				      (eql (d:instance-of (d:parent x)) 
-					   collection)))
-			     (d:player-in-roles col-2)))))
-		      (is-true col-assoc)
-		      (is (= (length (d:roles col-assoc)) 1))))))))))
+		    (is (= (length (d:player-in-roles col-2)) 2)))))))))
   (elephant:close-store))
 
 
@@ -1742,7 +1796,7 @@
 	  (date "http://www.w3.org/2001/XMLSchema#date")
 	  (de (d:get-item-by-id "http://isidorus/rdf2tm_mapping/scope#de"))
 	  (long "http://www.w3.org/2001/XMLSchema#unsignedLong"))
-      (is (= (length topics) 66))
+      (is (= (length topics) 65))
       (is (= (length occs) 23))
       (is (= (length assocs) 30))
       (is-true de)
@@ -2350,9 +2404,7 @@
 	  (zauberlehrling "http://some.where/poem/Der_Zauberlehrling")
 	  (prometheus "http://some.where/poem/Prometheus")
 	  (erlkoenig "http://some.where/ballad/Der_Erlkoenig")
-	  (country "http://some.where/types/Country")
-	  
-	  )
+	  (country "http://some.where/types/Country"))
       (is (= (count-if
 	      #'(lambda(x)
 		  (and (eql (d:instance-of x) supertype-subtype)
@@ -2708,6 +2760,227 @@
 	       6))))))
 
 
+(test test-empty-collection
+  "Tests importing of empty collections."
+  (let ((db-dir "data_base")
+	(tm-id "http://test-tm/")
+	(revision-1 100)
+	(document-id "doc-id")
+	(doc-1
+	 (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+		      "xmlns:arcs=\"http://test/arcs/\">"
+		      " <rdf:Description rdf:about=\"first-node\">"
+		      "  <arcs:arc rdf:parseType=\"Collection\" />"
+		      " </rdf:Description>"
+		      "</rdf:RDF>")))
+    (let ((rdf-node (elt (dom:child-nodes 
+			  (cxml:parse doc-1 (cxml-dom:make-dom-builder)))
+			 0)))
+      (is-true rdf-node)
+      (rdf-init-db :db-dir db-dir :start-revision revision-1)
+      (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
+				:document-id document-id)
+      (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 21))
+      (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1))
+      (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 0))
+      (is (= (length (elephant:get-instances-by-class 'd:NameC)) 0))
+      (let ((first-node (d:get-item-by-id "http://test-tm/first-node"
+					  :xtm-id document-id))
+	    (arc (d:get-item-by-id "http://test/arcs/arc"
+				   :xtm-id document-id))
+	    (rdf-nil (d:get-item-by-id constants:*rdf-nil*
+				       :xtm-id document-id))
+	    (subject (d:get-item-by-id constants:*rdf2tm-subject*))
+	    (object (d:get-item-by-id constants:*rdf2tm-object*)))
+	(is-true subject)
+	(is-true object)
+	(is-true first-node)
+	(is (= (length (d:psis first-node)) 1))
+	(is (string= (d:uri (first (d:psis first-node)))
+		     "http://test-tm/first-node"))
+	(is-true arc)
+	(is (= (length (d:psis arc)) 1))
+	(is (string= (d:uri (first (d:psis arc)))
+		     "http://test/arcs/arc"))
+	(is-true rdf-nil)
+	(is (= (length (d:psis rdf-nil)) 1))
+	(is (string= (d:uri (first (d:psis rdf-nil))) constants:*rdf-nil*))
+	(is (= (length (d:player-in-roles first-node)) 1))
+	(is (= (length (d:player-in-roles arc)) 0))
+	(is (= (length (d:player-in-roles rdf-nil)) 1))
+	(is-true (find-if
+		  #'(lambda(x)
+		      (and (eql (d:instance-of x) subject)
+			   (eql (d:instance-of (d:parent x)) arc)))
+		  (d:player-in-roles first-node)))
+	(is-true (find-if
+		  #'(lambda(x)
+		      (and (eql (d:instance-of x) object)
+			   (eql (d:instance-of (d:parent x)) arc)))
+		  (d:player-in-roles rdf-nil)))))))
+
+
+(test test-collection
+  "Tests importing of non-empty collections."
+  (let ((db-dir "data_base")
+	(tm-id "http://test-tm/")
+	(revision-1 100)
+	(document-id "doc-id")
+	(doc-1
+	 (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+		      "xmlns:arcs=\"http://test/arcs/\">"
+		      " <rdf:Description rdf:about=\"first-node\">"
+		      "  <arcs:arc rdf:parseType=\"Collection\">"
+		      "   <rdf:Description rdf:about=\"item-1\"/>"
+		      "   <arcs:Node rdf:about=\"item-2\"/>"
+		      "  </arcs:arc>"
+		      " </rdf:Description>"
+		      "</rdf:RDF>")))
+    (let ((rdf-node (elt (dom:child-nodes 
+			  (cxml:parse doc-1 (cxml-dom:make-dom-builder)))
+			 0)))
+      (is-true rdf-node)
+      (rdf-init-db :db-dir db-dir :start-revision revision-1)
+      (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
+				:document-id document-id)
+      (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 28))
+      (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 6))
+      (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 0))
+      (is (= (length (elephant:get-instances-by-class 'd:NameC)) 0))
+      (let ((first-node (d:get-item-by-id "http://test-tm/first-node"
+					  :xtm-id document-id))
+	    (arc (d:get-item-by-id "http://test/arcs/arc"
+				   :xtm-id document-id))
+	    (item-1 (d:get-item-by-id "http://test-tm/item-1"
+				      :xtm-id document-id))
+	    (item-2 (d:get-item-by-id "http://test-tm/item-2"
+				      :xtm-id document-id))
+	    (node (d:get-item-by-id "http://test/arcs/Node"
+				    :xtm-id document-id))
+	    (rdf-first (d:get-item-by-id constants:*rdf-first*
+					 :xtm-id document-id))
+	    (rdf-rest (d:get-item-by-id constants:*rdf-rest*
+					:xtm-id document-id))
+	    (rdf-nil (d:get-item-by-id constants:*rdf-nil*
+				       :xtm-id document-id))
+	    (subject (d:get-item-by-id constants:*rdf2tm-subject*
+				       :xtm-id document-id))
+	    (object (d:get-item-by-id constants:*rdf2tm-object*
+				      :xtm-id document-id))
+	    (instance (d:get-item-by-psi constants:*instance-psi*))
+	    (type (d:get-item-by-psi constants:*type-psi*))
+	    (type-instance (d:get-item-by-psi constants:*type-instance-psi*)))
+	(is-true first-node)
+	(is (= (length (d:psis first-node)) 1))
+	(is (string= (d:uri (first (d:psis first-node)))
+		     "http://test-tm/first-node"))
+	(is (= (length (d:player-in-roles first-node)) 1))
+	(is-true arc)
+	(is (= (length (d:psis arc)) 1))
+	(is (string= (d:uri (first (d:psis arc)))
+		     "http://test/arcs/arc"))
+	(is (= (length (d:player-in-roles arc)) 0))
+	(is-true item-1)
+	(is (= (length (d:psis item-1)) 1))
+	(is (string= (d:uri (first (d:psis item-1)))
+		     "http://test-tm/item-1"))
+	(is (= (length (d:player-in-roles item-1)) 1))
+	(is-true item-2)
+	(is (= (length (d:psis item-2)) 1))
+	(is (string= (d:uri (first (d:psis item-2)))
+		     "http://test-tm/item-2"))
+	(is (= (length (d:player-in-roles item-2)) 2))
+	(is-true node)
+	(is (= (length (d:psis node)) 1))
+	(is (string= (d:uri (first (d:psis node)))
+		     "http://test/arcs/Node"))
+	(is (= (length (d:player-in-roles node)) 1))
+	(is-true rdf-first)
+	(is-true rdf-rest)
+	(is-true rdf-nil)
+	(is (= (length (d:player-in-roles rdf-nil)) 1))
+	(is-true subject)
+	(is-true object)
+	(let ((uuid-1
+	       (d:player
+		(find-if 
+		 #'(lambda(x)
+		     (not (eql x (first (d:player-in-roles first-node)))))
+		 (d:roles (d:parent (first (d:player-in-roles first-node)))))))
+	      (uuid-2
+	       (d:player
+		(find-if 
+		 #'(lambda(x)
+		     (not (eql x (first (d:player-in-roles rdf-nil)))))
+		 (d:roles (d:parent (first (d:player-in-roles rdf-nil))))))))
+	  (is-true uuid-1)
+	  (is (= (length (d:psis uuid-1)) 0))
+	  (is (= (length (d:player-in-roles uuid-1)) 3))
+	  (is-true uuid-2)
+	  (is (= (length (d:psis uuid-2)) 0))
+	  (is (= (length (d:player-in-roles uuid-2)) 3))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) subject)
+			     (eql (d:instance-of (d:parent x)) arc)))
+		    (d:player-in-roles first-node)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) object)
+			     (eql (d:instance-of (d:parent x)) arc)))
+		    (d:player-in-roles uuid-1)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) subject)
+			     (eql (d:instance-of (d:parent x)) rdf-first)))
+		    (d:player-in-roles uuid-1)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) subject)
+			     (eql (d:instance-of (d:parent x)) rdf-rest)))
+		    (d:player-in-roles uuid-1)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) object)
+			     (eql (d:instance-of (d:parent x)) rdf-first)))
+		    (d:player-in-roles item-1)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) object)
+			     (eql (d:instance-of (d:parent x)) rdf-rest)))
+		    (d:player-in-roles uuid-2)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) subject)
+			     (eql (d:instance-of (d:parent x)) rdf-first)))
+		    (d:player-in-roles uuid-2)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) subject)
+			     (eql (d:instance-of (d:parent x)) rdf-rest)))
+		    (d:player-in-roles uuid-2)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) object)
+			     (eql (d:instance-of (d:parent x)) rdf-rest)))
+		    (d:player-in-roles rdf-nil)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) object)
+			     (eql (d:instance-of (d:parent x)) rdf-first)))
+		    (d:player-in-roles item-2)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) instance)
+			     (eql (d:instance-of (d:parent x)) type-instance)))
+		    (d:player-in-roles item-2)))
+	  (is-true (find-if
+		    #'(lambda(x)
+			(and (eql (d:instance-of x) type)
+			     (eql (d:instance-of (d:parent x)) type-instance)))
+		    (d:player-in-roles node))))))))
+
+
 (defun run-rdf-importer-tests()
   (when elephant:*store-controller*
     (elephant:close-store))
@@ -2726,4 +2999,6 @@
   (it.bese.fiveam:run! 'test-poems-rdf-occurrences)
   (it.bese.fiveam:run! 'test-poems-rdf-associations)
   (it.bese.fiveam:run! 'test-poems-rdf-typing)
-  (it.bese.fiveam:run! 'test-poems-rdf-topics))
\ No newline at end of file
+  (it.bese.fiveam:run! 'test-poems-rdf-topics)
+  (it.bese.fiveam:run! 'test-empty-collection)
+  (it.bese.fiveam:run! 'test-collection))
\ 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	Thu Aug 13 15:47:53 2009
@@ -101,8 +101,6 @@
   (format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove
   (tm-id-p tm-id "import-node")
   (parse-node elem)
-  ;TODO: handle Collections that are made manually without
-  ;      parseType="Collection" -> see also import-arc
   (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
 	(fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
     (let ((about (get-absolute-attribute elem tm-id xml-base "about"))	   
@@ -158,76 +156,123 @@
   (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
 	(fn-xml-base (get-xml-base elem :old-base xml-base))
 	(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
-	(parseType (get-ns-attribute elem "parseType")))
-    (when (or (not parseType)
-	      (and parseType
-		   (string/= parseType "Collection")))
-      (when UUID
-	(parse-properties-of-node elem UUID)
-	(with-tm (start-revision document-id tm-id)
-	  (let ((this (get-item-by-id UUID :xtm-id document-id
-				      :revision start-revision)))
-	    (let ((literals (append (get-literals-of-property elem fn-xml-lang)
-				    (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
-			   (get-types-of-node-content elem tm-id fn-xml-base)
-			   (when (get-ns-attribute elem "type")
-			     (list :ID nil
-				   :topicid (get-ns-attribute elem "type")
-				   :psi (get-ns-attribute elem "type"))))))
-		  (super-classes
-		   (get-super-classes-of-node-content elem tm-id xml-base)))
-	      (make-literals this literals tm-id start-revision
-			     :document-id document-id)
-	      (make-associations this associations xml-importer::tm
-				 start-revision :document-id document-id)
-	      (make-types this types xml-importer::tm start-revision
-			  :document-id document-id)
-	      (make-super-classes this super-classes xml-importer::tm
-				  start-revision :document-id document-id))))))
-    (make-recursion-from-arc elem tm-id start-revision
-			     :document-id document-id
-			     :xml-base xml-base :xml-lang xml-lang)))
+	(parseType (get-ns-attribute elem "parseType"))
+	(content (child-nodes-or-text elem :trim t)))
+    (with-tm (start-revision document-id tm-id)
+      (if (and (string= parseType "Collection")
+	       (= (length content) 0))
+	    (make-topic-stub *rdf-nil* nil nil nil start-revision
+			     xml-importer::tm :document-id document-id)
+	  (let ((this-topic
+		 (when (or (not parseType)
+			   (and parseType
+				(string/= parseType "Collection")))
+		   (when UUID
+		     (parse-properties-of-node elem UUID)
+		     (let ((this
+			    (get-item-by-id UUID :xtm-id document-id
+					    :revision start-revision)))
+		       (let ((literals
+			      (append (get-literals-of-property
+				       elem fn-xml-lang)
+				      (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
+				(get-types-of-node-content elem tm-id fn-xml-base)
+				(when (get-ns-attribute elem "type")
+				  (list :ID nil
+					:topicid (get-ns-attribute elem "type")
+					:psi (get-ns-attribute elem "type"))))))
+			     (super-classes
+			      (get-super-classes-of-node-content
+			       elem tm-id xml-base)))
+			 (make-literals this literals tm-id start-revision
+					:document-id document-id)
+			 (make-associations this associations xml-importer::tm
+					    start-revision :document-id document-id)
+			 (make-types this types xml-importer::tm start-revision
+				     :document-id document-id)
+			 (make-super-classes
+			  this super-classes xml-importer::tm
+			  start-revision :document-id document-id))
+		       this)))))
+	    (make-recursion-from-arc elem tm-id start-revision
+				     :document-id document-id
+				     :xml-base xml-base :xml-lang xml-lang)
+	    this-topic)))))
 
 
-(defun make-collection (elem owner-top tm-id start-revision
+(defun make-collection (elem tm-id start-revision
 			&key (document-id *document-id*)
 			(xml-base nil) (xml-lang nil))
-  "Creates a TM association with a subject role containing the collection
-   entry point and as many roles of the type 'object' as items exists."
-  (declare (d:TopicC owner-top))
+  "Creates a collection structure of a node that contains
+   parseType='Collection."
+  (declare (dom:element elem))
   (with-tm (start-revision document-id tm-id)
     (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
 	  (fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
-	  (subject (make-topic-stub *rdf2tm-subject* nil nil nil start-revision
-				    xml-importer::tm :document-id document-id))
-	  (object (make-topic-stub *rdf2tm-object* nil nil nil start-revision
-				   xml-importer::tm :document-id document-id)))
-      (let ((association-type (make-topic-stub *rdf2tm-collection* nil nil nil
-					       start-revision xml-importer::tm
-					       :document-id document-id))
-	    (roles
-	     (append
-	      (loop for item across (child-nodes-or-text elem :trim t)
-		 collect (let ((item-top (import-node item tm-id start-revision
-						      :document-id document-id
-						      :xml-base fn-xml-base
-						      :xml-lang fn-xml-lang)))
-			   (list :player item-top
-				 :instance-of object)))
-	      (list (list :player owner-top
-			  :instance-of subject)))))
-	(add-to-topicmap
-	 xml-importer::tm
-	 (make-construct 'd:AssociationC
-			 :start-revision start-revision
-			 :instance-of association-type
-			 :roles roles))))))
+	  (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
+      (let ((this (make-topic-stub nil nil nil UUID start-revision
+				   xml-importer::tm
+				   :document-id document-id))
+	    (items (loop for item across (child-nodes-or-text elem :trim t)
+		      collect (import-node item tm-id start-revision
+					   :document-id document-id
+					   :xml-base fn-xml-base
+					   :xml-lang fn-xml-lang))))
+	(let ((last-blank-node this))
+	  (dotimes (index (length items))
+	    (let ((is-end
+		   (if (= index (- (length items) 1))
+		       t
+		       nil)))
+	      (let ((new-blank-node
+		     (make-collection-association
+		      last-blank-node (elt items index) tm-id  start-revision
+		      :is-end is-end :document-id document-id)))
+		(setf last-blank-node new-blank-node)))))))))
+
+
+(defun make-collection-association (current-blank-node first-object tm-id
+				    start-revision &key (is-end nil)
+				    (document-id *document-id*))
+  "Creates a 'first'-association between the current-blank-node and the
+   first-object. If is-end is set to true another association between
+   current-blank-node and the topic rdf:nil is created. Otherwise this
+   associaiton is made from the current-blank-node to a new created blank
+   node."
+  (declare (d:TopicC current-blank-node first-object))
+  (with-tm (start-revision document-id tm-id)
+    (let ((first-arc
+	   (make-topic-stub *rdf-first* nil nil nil start-revision 
+			    xml-importer::tm :document-id document-id))
+	  (rest-arc
+	   (make-topic-stub *rdf-rest* nil nil nil start-revision
+			    xml-importer::tm :document-id document-id)))
+      (make-association-with-nodes current-blank-node first-object first-arc
+				   xml-importer::tm start-revision
+				   :document-id document-id)
+      (if is-end
+	  (let ((rdf-nil (make-topic-stub *rdf-nil* nil nil nil
+					  start-revision xml-importer::tm
+					  :document-id document-id)))
+	    (make-association-with-nodes
+	     current-blank-node rdf-nil rest-arc xml-importer::tm
+	     start-revision :document-id document-id)
+	    nil)
+	  (let ((new-blank-node (make-topic-stub
+				 nil nil nil (get-uuid) start-revision
+				 xml-importer::tm :document-id document-id)))
+	    (make-association-with-nodes
+	     current-blank-node new-blank-node rest-arc xml-importer::tm
+	     start-revision :document-id document-id)
+	    new-blank-node)))))
 
 
 (defun make-literals (owner-top literals tm-id start-revision
@@ -801,10 +846,15 @@
 		   (not (and (string= prop-name "subClassOf")
 			     (string= prop-ns *rdfs-ns*)))))
        collect (let ((prop-xml-base (get-xml-base property
-						  :old-base fn-xml-base)))
+						  :old-base fn-xml-base))
+		     (content (child-nodes-or-text property :trim t))
+		     (parseType (get-ns-attribute property "parseType")))
 		 (let ((resource
-			(get-absolute-attribute property tm-id
-						fn-xml-base "resource"))
+			(if (and (string= parseType "Collection")
+				 (= (length content) 0))
+			    *rdf-nil*
+			    (get-absolute-attribute property tm-id
+						    fn-xml-base "resource")))
 		       (nodeID (get-ns-attribute property "nodeID"))
 		       (UUID (get-ns-attribute property "UUID"
 					       :ns-uri *rdf2tm-ns*))
@@ -813,7 +863,7 @@
 		       (full-name (get-type-of-node-name property)))
 		   (if (or nodeID resource UUID)
 		       (list :type full-name
-			     :topicid (or nodeID resource UUID)
+			     :topicid (or resource nodeID UUID)
 			     :psi resource
 			     :ID ID)
 		       (let ((refs (get-node-refs
@@ -851,8 +901,7 @@
   (let ((fn-xml-base (get-xml-base arc :old-base xml-base))
 	(fn-xml-lang (get-xml-lang arc :old-lang xml-lang))
 	(content (child-nodes-or-text arc))
-	(parseType (get-ns-attribute arc "parseType"))
-	(UUID (get-ns-attribute arc "UUID" :ns-uri *rdf2tm-ns*)))
+	(parseType (get-ns-attribute arc "parseType")))
     (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype"))
 	  (type (get-absolute-attribute arc tm-id xml-base "type"))
 	  (resource (get-absolute-attribute arc tm-id xml-base "resource"))
@@ -860,32 +909,27 @@
 	  (literals (get-literals-of-property arc xml-lang)))
       (if (and parseType
 	       (string= parseType "Collection"))
-	  (let ((this
-		 (with-tm (start-revision document-id tm-id)
-		   (make-topic-stub nil nil nil UUID start-revision
-				    xml-importer::tm
-				    :document-id document-id))))
-	    (make-collection arc this tm-id start-revision
-			     :document-id document-id
-			     :xml-base xml-base
-			     :xml-lang xml-lang))
+	  (make-collection arc tm-id start-revision
+			   :document-id document-id
+			   :xml-base xml-base
+			   :xml-lang xml-lang)
 	  (if (or datatype resource nodeID
 		  (and parseType
 		       (string= parseType "Literal"))
 		  (and content
 		       (stringp content)))
-	      t;; do nothing current elem is a literal node that has been
-	       ;; already imported as an occurrence
+	      nil;; do nothing current elem is a literal node that has been
+	         ;; already imported as an occurrence
 	      (if (or type literals
 		      (and parseType
 			   (string= parseType "Resource")))
 		  (loop for item across content
-		     do (import-arc item tm-id start-revision
-				    :document-id document-id
-				    :xml-base fn-xml-base
-				    :xml-lang fn-xml-lang))
+		     collect (import-arc item tm-id start-revision
+					 :document-id document-id
+					 :xml-base fn-xml-base
+					 :xml-lang fn-xml-lang))
 		  (loop for item across content
-		     do (import-node item tm-id start-revision
-				     :document-id document-id
-				     :xml-base xml-base
-				     :xml-lang xml-lang))))))))
+		     collect (import-node item tm-id start-revision
+					  :document-id document-id
+					  :xml-base xml-base
+					  :xml-lang xml-lang))))))))
\ No newline at end of file

Modified: trunk/src/xml/rdf/rdf_core_psis.xtm
==============================================================================
--- trunk/src/xml/rdf/rdf_core_psis.xtm	(original)
+++ trunk/src/xml/rdf/rdf_core_psis.xtm	Thu Aug 13 15:47:53 2009
@@ -23,13 +23,6 @@
       <value>object</value>
     </name>
   </topic>
-  
-  <topic id="collection">
-    <subjectIdentifier href="http://isidorus/rdf2tm_mapping#collection"/>
-    <name>
-      <value>object</value>
-    </name>
-  </topic>
 
   <topic id="supertype-subtype">
     <subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype-subtype"/>

Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp	(original)
+++ trunk/src/xml/rdf/rdf_tools.lisp	Thu Aug 13 15:47:53 2009
@@ -31,7 +31,6 @@
 		*rdf-nil*
 		*rdf-first*
 		*rdf-rest*
-		*rdf2tm-collection*
 		*rdf2tm-scope-prefix*)
   (:import-from :xml-constants
 		*rdf_core_psis.xtm*)




More information about the Isidorus-cvs mailing list