From lgiessmann at common-lisp.net  Fri Apr  1 10:04:00 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 06:04:00 -0400
Subject: [isidorus-cvs] r398 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q5bCy-0004Cp-Rx@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 06:04:00 2011
New Revision: 398

Log:
TM-SPARQL: finished unit-tests for the special predicates rdf:type, a, and tmdm:type => fixed a problem with rdf:type

Modified:
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Fri Apr  1 06:04:00 2011
@@ -144,7 +144,14 @@
 					 :elem-type 'IRI
 					 :value *type-psi*)))
 	    ((string-starts-with trimmed-str "<")
-	     (parse-base-suffix-pair construct trimmed-str))
+	     (let ((result (parse-base-suffix-pair construct trimmed-str)))
+	       (if (and (not (variable-p (getf result :value)))
+			(string= (value (getf result :value)) *rdf-type*))
+		   (list :next-query (getf result :next-query)
+			 :value (make-instance 'SPARQL-Triple-Elem
+					       :elem-type 'IRI
+					       :value *type-psi*))
+		   result)))
 	    ((or (string-starts-with trimmed-str "?")
 		 (string-starts-with trimmed-str "$"))
 	     (let ((result
@@ -166,8 +173,14 @@
 			     trimmed-str (original-query construct)
 			     "an IRI of the form prefix:suffix or <iri> but found a literal.")))
 		   (parse-literal-elem construct trimmed-str))
-		 (parse-prefix-suffix-pair construct trimmed-str)))))))
-
+		 (let ((result (parse-prefix-suffix-pair construct trimmed-str)))
+		   (if (and (not (variable-p (getf result :value)))
+			    (string= (value (getf result :value)) *rdf-type*))
+		       (list :next-query (getf result :next-query)
+			     :value (make-instance 'SPARQL-Triple-Elem
+						   :elem-type 'IRI
+						   :value *type-psi*))
+		       result))))))))
 
 (defgeneric parse-literal-elem (construct query-string)
   (:documentation "A helper-function that returns a literal vaue of the form
@@ -338,7 +351,7 @@
   (:method ((construct SPARQL-Query) (query-string String))
     (let* ((trimmed-str (cut-comment query-string))
 	   (delimiters (list "." ";" "}" "<" " " (string #\newline)
-			     (string #\tab) "#"))
+			     (string #\tab))) ; "#"))
 	   (end-pos (search-first delimiters trimmed-str))
 	   (elem-str (when end-pos
 		       (subseq trimmed-str 0 end-pos)))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 06:04:00 2011
@@ -1635,7 +1635,7 @@
 		 "SELECT * WHERE {
                   ?subj1 <http://some.where/tmsparql/first-name> \"Johann Wolfgang\".
                   ?subj2 <http://some.where/tmsparql/last-name> 'von Goethe'^^"
-	              *xml-string* ".
+	                                   *xml-string* ".
                   ?subj3 <http://some.where/tmsparql/date-of-birth> '28.08.1749'^^"
                                            *xml-date* ".
 	          ?subj4 <http://some.where/tmsparql/date-of-death> '22.03.1832'^^"
@@ -1683,5 +1683,31 @@
     (is-true (d:get-item-by-psi *rdf-type* :revision 0))))
 
 
+(test test-all-2
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX pref:<http://www.w3.org/1999/02/>
+                  SELECT * WHERE {
+                  ?subj1 a <http://some.where/tmsparql/author> .
+                  ?subj2 <http://www.w3.org/1999/02/22-rdf-syntax-ns#type> <http://some.where/tmsparql/author> .
+                  ?subj3 <http://psi.topicmaps.org/iso13250/model/type> <http://some.where/tmsparql/author> .
+	          ?subj4 pref:22-rdf-syntax-ns#type <http://some.where/tmsparql/author>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 4))
+      (map 'list #'(lambda(item)
+		     (cond ((or (string= (getf item :variable) "subj1")
+				(string= (getf item :variable) "subj2")
+				(string= (getf item :variable) "subj3")
+				(string= (getf item :variable) "subj4"))
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/tmsparql/author/goethe>")))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
+
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Fri Apr  1 11:22:42 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 07:22:42 -0400
Subject: [isidorus-cvs] r399 - in trunk/src: TM-SPARQL model unit_tests
Message-ID: <E1Q5cR8-0000xe-Is@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 07:22:42 2011
New Revision: 399

Log:
TM-SPARQL: finished the unit-tests for the special predicate tms:reifier; fixed a problem with 2-dim. lists; fixed a bug in get-item-by-content; added get-most-recent-version to CharacteristicC, PointerC, and RoleC

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_special_uris.lisp
   trunk/src/model/datamodel.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Fri Apr  1 07:22:42 2011
@@ -769,14 +769,16 @@
 	     (pred (when (iri-p (predicate construct))
 		     (value (predicate construct)))))
 	(cond ((variable-p (object construct))
-	       (append (filter-characteristics
-			subj pred nil nil :revision revision)
-		       (filter-associations
-			subj pred nil :revision revision)))
+	       (when (typep subj 'TopicC)
+		 (append (filter-characteristics
+			  subj pred nil nil :revision revision)
+			 (filter-associations
+			  subj pred nil :revision revision))))
 	      ((literal-p (object construct))
-	       (filter-characteristics
-		subj pred (value (object construct))
-		(literal-datatype (object construct)) :revision revision))
+	       (when (typep subj 'TopicC)
+		 (filter-characteristics
+		  subj pred (value (object construct))
+		  (literal-datatype (object construct)) :revision revision)))
 	      ((iri-p (object construct))
 	       (filter-associations subj pred (value (object construct))
 				    :revision revision)))))))

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Fri Apr  1 07:22:42 2011
@@ -114,16 +114,19 @@
 		   (let ((player-top
 			  (player (value subj) :revision revision)))
 		     (when player-top
-		       (list :subject subj-uri
-			     :predicate pred-uri
-			     :object (sparql-node player-top :revision revision)))))
+		       (list
+			(list
+			 :subject subj-uri
+			 :predicate pred-uri
+			 :object (sparql-node player-top :revision revision))))))
 		  ((not (variable-p obj))
 		   (let ((parent-roles
 			  (player-in-roles (value obj) :revision revision)))
 		     (loop for role in parent-roles
-			collect (list :subject (sparql-node role :revision revision)
-				      :predicate pred-uri
-				      :object (sparql-node (player role :revision revision)
+			collect (list
+				 :subject (sparql-node role :revision revision)
+				 :predicate pred-uri
+				 :object (sparql-node (player role :revision revision)
 							   :revision revision)))))
 		  (t ; only pred is given
 		   (let ((all-roles
@@ -163,9 +166,10 @@
 		((not (variable-p obj))
 		 (let ((parent-assoc (parent (value obj) :revision revision)))
 		   (when revision
-		     (list :subject (sparql-node parent-assoc :revision revision)
-			   :predicate pred-uri
-			   :object obj-uri))))
+		     (list
+		      (list :subject (sparql-node parent-assoc :revision revision)
+			    :predicate pred-uri
+			    :object obj-uri)))))
 		(t ; only pred is given
 		 (let ((assocs
 			(remove-null
@@ -211,9 +215,10 @@
 		((not (variable-p obj))
 		 (let ((parent-top (parent (value obj) :revision revision)))
 		   (when revision
-		     (list :subject (sparql-node parent-top :revision revision)
-			   :predicate pred-uri
-			   :object obj-uri))))
+		     (list
+		      (list :subject (sparql-node parent-top :revision revision)
+			    :predicate pred-uri
+			    :object obj-uri)))))
 		(t ; only pred is given
 		 (let ((topics
 			(remove-null
@@ -353,9 +358,10 @@
 		 (let ((reifier-top
 			(reifier (value subj) :revision revision)))
 		   (when reifier-top
-		     (list :subject subj-uri
-			   :predicate pred-uri
-			   :object (sparql-node reifier-top :revision revision)))))
+		     (list
+		      (list :subject subj-uri
+			    :predicate pred-uri
+			    :object (sparql-node reifier-top :revision revision))))))
 		((not (variable-p obj))
 		 (let ((reified-cons
 			(reified-construct (value obj) :revision revision)))

Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp	(original)
+++ trunk/src/model/datamodel.lisp	Fri Apr  1 07:22:42 2011
@@ -749,10 +749,13 @@
 						 (typep inst class-symbol))
 					     db-instances)))
       (if revision
-	  (remove-if #'null
-		     (map 'list #'(lambda(inst)
-				    (find-item-by-revision inst revision))
-			  filtered-instances))
+	  (remove-null
+	   (map 'list #'(lambda(inst)
+			  (if (typep inst 'CHaracteristicC)
+			      (find-item-by-revision inst revision
+						     (parent inst :revision revision))
+			      (find-item-by-revision inst revision)))
+		filtered-instances))
 	  filtered-instances))))
 
 
@@ -809,15 +812,17 @@
 
 (defun get-item-by-content (content &key (revision *TM-REVISION*))
   "Finds characteristics by their (atomic) content."
-  (flet
-      ((get-existing-instances (class-symbol)
-         (delete-if-not
-	  #'(lambda (constr)
-	      (find-item-by-revision constr revision))
-	  (elephant:get-instances-by-value class-symbol 'charvalue content))))
-    (nconc (get-existing-instances 'OccurenceC)
-           (get-existing-instances 'NameC)
-	   (get-existing-instances 'VariantC))))
+  (let ((constructs
+	 (nconc (elephant:get-instances-by-value 'NameC 'Charvalue content)
+		(elephant:get-instances-by-value 'OccurrenceC 'Charvalue content)
+		(elephant:get-instances-by-value 'VariantC 'Charvalue content))))
+    (first
+     (remove-if
+      #'(lambda(construct)
+	  (or (string/= (charvalue construct) content)
+	      (not (find-item-by-revision construct revision
+					  (parent construct :revision revision)))))
+      constructs))))
 
 
 (defmacro with-revision (revision &rest body)
@@ -1154,6 +1159,24 @@
       construct)))
 
 
+(defmethod find-most-recent-revision ((construct CharacteristicC))
+  (loop for c-assoc in (slot-p construct 'parent)
+     when (find-most-recent-revision c-assoc)
+     return construct))
+
+
+(defmethod find-most-recent-revision ((construct PointerC))
+  (loop for p-assoc in (slot-p construct 'identified-construct)
+     when (find-most-recent-revision p-assoc)
+     return construct))
+
+
+(defmethod find-most-recent-revision ((construct RoleC))
+  (loop for r-assoc in (slot-p construct 'parent)
+     when (find-most-recent-revision r-assoc)
+     return construct))
+
+
 (defun add-version-info(construct start-revision)
   "Adds 'construct' to the given version.
    If the construct is a VersionedConstructC add-to-version-history

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 07:22:42 2011
@@ -1709,5 +1709,48 @@
 	   r-1))))
 
 
+(test test-all-3
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/ii/goethe-occ> tms:reifier ?obj1.
+                   ?subj1 tms:reifier <http://some.where/ii/goethe-name-reifier>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 2))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "subj1")
+			    (is (string=
+				 (first (getf item :result))
+				 (concat "_:n"
+					 (write-to-string
+					  (elephant::oid
+					   (d:get-item-by-content "von Goethe")))))))
+			   ((string= (getf item :variable) "obj1")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/goethe-occ-reifier>")))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
+
+(test test-all-4
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/ii/goethe-occ> tms:reifier ?obj1.
+                   ?subj1 tms:reifier <http://some.where/ii/goethe-name-reifier>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 2))
+      )))
+
+
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Fri Apr  1 12:50:49 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 08:50:49 -0400
Subject: [isidorus-cvs] r400 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q5doP-0001Ce-Dj@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 08:50:49 2011
New Revision: 400

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri tms:role => fixed a bug when the object is a resource and not a variable

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_special_uris.lisp
   trunk/src/unit_tests/sparql_test.lisp
   trunk/src/unit_tests/sparql_test.xtm

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Fri Apr  1 08:50:49 2011
@@ -16,10 +16,9 @@
 	   :init-tm-sparql))
 
 
-
 (in-package :TM-SPARQL)
 
-(defvar *empty-label* "_empty_label_symbol" "A label symobl for empyt prefix labels")
+(defvar *empty-label* "_empty_label_symbol" "A label symbol for empyt prefix labels")
 
 (defvar *equal-operators* nil "A Table taht contains tuples of 
                                classes and equality operators.")
@@ -779,7 +778,8 @@
 		 (filter-characteristics
 		  subj pred (value (object construct))
 		  (literal-datatype (object construct)) :revision revision)))
-	      ((iri-p (object construct))
+	      ((and (iri-p (object construct))
+		    (typep subj 'TopicC))
 	       (filter-associations subj pred (value (object construct))
 				    :revision revision)))))))
 

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Fri Apr  1 08:50:49 2011
@@ -151,7 +151,7 @@
 	(when (and (or (variable-p subj)
 		       (typep (value subj) 'd:AssociationC))
 		   (or (variable-p obj)
-		       (typep (value subj) 'd:RoleC)))
+		       (typep (value obj) 'd:RoleC)))
 	  (cond ((and (not (variable-p subj))
 		      (not (variable-p obj)))
 		 (when (find obj (roles (value subj) :revision revision))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 08:50:49 2011
@@ -1744,12 +1744,59 @@
     (let* ((q-1 (concat
 		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
                   SELECT * WHERE {
-                   <http://some.where/ii/goethe-occ> tms:reifier ?obj1.
-                   ?subj1 tms:reifier <http://some.where/ii/goethe-name-reifier>"
+                   ?assoc tms:reifier <http://some.where/ii/association-reifier>.
+                   <http://some.where/ii/association> tms:role ?roles.
+                   ?assoc2 tms:role <http://some.where/ii/role-2>"
                  "}"))
-	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
-      (is-true (= (length r-1) 2))
-      )))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
+	   (role-1 (concat "_:r" (write-to-string
+				  (elephant::oid
+				   (first (roles
+					   (get-item-by-item-identifier 
+					    "http://some.where/ii/association"
+					    :revision 0)))))))
+	   (role-2 (concat "_:r" (write-to-string
+				  (elephant::oid
+				   (second (roles
+					    (get-item-by-item-identifier 
+					     "http://some.where/ii/association"
+					     :revision 0))))))))
+      (is-true (= (length r-1) 3))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "assoc")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/association>")))
+			    ((string= (getf item :variable) "roles")
+			    (is (or (string= (first (getf item :result))
+					     role-1)
+				    (string= (first (getf item :result))
+					     role-2)
+				    (string= (first (getf item :result))
+					     "<http://some.where/ii/role-2>")))
+			     (is (or (string= (second (getf item :result))
+					      role-1)
+				     (string= (second (getf item :result))
+					      role-2)
+				     (string= (second (getf item :result))
+					      "<http://some.where/ii/role-2>"))))
+			    ((string= (getf item :variable) "assoc2")
+			     (is (string= (first (getf item :result))
+					  "<http://some.where/ii/association>")))
+			    (t
+			     (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
+
+
+
+
+;TODO:  tms:player, tms:topicProperty, tms:scope, tms:value, complex filter
+;TODO: "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+;       SELECT * WHERE {
+;        ?assoc tms:reifier <http://some.where/ii/association-reifier>.
+;        ?assoc tms:role ?roles}
+; => ?assoc = http://some.where/ii/association
+; => ?roles = (http://some.where/ii/role-2, _:r????)
 
 
 (defun run-sparql-tests ()

Modified: trunk/src/unit_tests/sparql_test.xtm
==============================================================================
--- trunk/src/unit_tests/sparql_test.xtm	(original)
+++ trunk/src/unit_tests/sparql_test.xtm	Fri Apr  1 08:50:49 2011
@@ -201,13 +201,14 @@
   </tm:topic>
 
   <tm:association reifier="http://some.where/ii/association-reifier">
-    <tm:itemIdentity href="http://somw.where/ii/association"/>
+    <tm:itemIdentity href="http://some.where/ii/association"/>
     <tm:type><tm:topicRef href="#written-by"/></tm:type>
     <tm:role reifier="http://some.where/ii/role-reifier">
       <tm:type><tm:topicRef href="#writer"/></tm:type>
       <tm:topicRef href="#goethe"/>
     </tm:role>
     <tm:role>
+      <tm:itemIdentity href="http://some.where/ii/role-2"/>
       <tm:type><tm:topicRef href="#written"/></tm:type>
       <tm:topicRef href="#zauberlehrling"/>
     </tm:role>



From lgiessmann at common-lisp.net  Fri Apr  1 13:05:56 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 09:05:56 -0400
Subject: [isidorus-cvs] r401 - trunk/src/unit_tests
Message-ID: <E1Q5e32-0002iH-Ha@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 09:05:56 2011
New Revision: 401

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri tms:player

Modified:
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 09:05:56 2011
@@ -1788,11 +1788,44 @@
 
 
 
+(test test-all-5
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/ii/role-2> tms:player ?player.
+                   ?role tms:player <http://some.where/psis/poem/zauberlehrling>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 2))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "player")
+			    (is (string=
+				 (first (getf item :result))
+				 "<http://some.where/psis/poem/zauberlehrling>")))
+			   ((string= (getf item :variable) "role")
+			    (is (= (length (getf item :result)) 2))
+			    ;one role is the type-instance role
+			    (is (or (string= (first (getf item :result))
+					     "<http://some.where/ii/role-2>")
+				    (string= (second (getf item :result))
+					     "<http://some.where/ii/role-2>"))))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
 
 
-;TODO:  tms:player, tms:topicProperty, tms:scope, tms:value, complex filter
-;TODO: "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
-;       SELECT * WHERE {
+
+
+;TODO: tms:topicProperty, tms:scope, tms:value, complex filter
+;      <obj> <pred> <subj>
+;      ?obj <pred> ?subj
+;      <subj> ?pred ?obj
+;      ?subj ?pred <obj>
+;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+;      SELECT * WHERE {
 ;        ?assoc tms:reifier <http://some.where/ii/association-reifier>.
 ;        ?assoc tms:role ?roles}
 ; => ?assoc = http://some.where/ii/association



From lgiessmann at common-lisp.net  Fri Apr  1 13:23:24 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 09:23:24 -0400
Subject: [isidorus-cvs] r402 - trunk/src/unit_tests
Message-ID: <E1Q5eJw-0003nw-5Q@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 09:23:24 2011
New Revision: 402

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri tms:topicProperty

Modified:
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 09:23:24 2011
@@ -1787,7 +1787,6 @@
 	   r-1))))
 
 
-
 (test test-all-5
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
@@ -1817,9 +1816,51 @@
 	   r-1))))
 
 
+(test test-all-6
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/tmsparql/author/goethe> tms:topicProperty ?props.
+                   ?subj1 tms:topicProperty <http://some.where/ii/goethe-untyped-name>.
+                   ?subj2 tms:topicProperty <http://some.where/ii/goethe-occ>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
+	   (prop-ids
+	    (map 'list
+		 #'(lambda(prop)
+		     (if (item-identifiers prop :revision 0)
+			 (concat "<" (d:uri (first (item-identifiers
+						    prop :revision 0))) ">")
+			 (if (typep prop 'OccurrenceC)
+			     (concat "_:o" (write-to-string (elephant::oid prop)))
+			     (concat "_:n" (write-to-string (elephant::oid prop))))))
+		 (append (names (get-item-by-psi
+				 "http://some.where/tmsparql/author/goethe"
+				 :revision 0))
+			 (occurrences (get-item-by-psi
+				       "http://some.where/tmsparql/author/goethe"
+				       :revision 0))))))
+      (is-true (= (length r-1) 3))
+      (map 'list #'(lambda(item)
+		     (cond ((or (string= (getf item :variable) "subj1")
+				(string= (getf item :variable) "subj2"))
+			    (is (string=
+				 (first (getf item :result))
+				 "<http://some.where/tmsparql/author/goethe>")))
+			   ((string= (getf item :variable) "props")
+			    (is (= (length (getf item :result)) 8))
+			    (is-false (intersection prop-ids (getf item :result))))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
+
 
 
-;TODO: tms:topicProperty, tms:scope, tms:value, complex filter
+;TODO: tms:scope, tms:value, complex filter
 ;      <obj> <pred> <subj>
 ;      ?obj <pred> ?subj
 ;      <subj> ?pred ?obj



From lgiessmann at common-lisp.net  Fri Apr  1 13:30:30 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 09:30:30 -0400
Subject: [isidorus-cvs] r403 - trunk/src/unit_tests
Message-ID: <E1Q5eQo-0004J2-JG@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 09:30:30 2011
New Revision: 403

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri tms:scope

Modified:
   trunk/src/unit_tests/sparql_test.lisp
   trunk/src/unit_tests/sparql_test.xtm

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 09:30:30 2011
@@ -1858,6 +1858,30 @@
 	   r-1))))
 
 
+(test test-all-7
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/ii/zb/occurrence> tms:scope ?scope.
+                   ?owner tms:scope <http://some.where/tmsparql/de>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 2))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "scope")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/tmsparql/de>")))
+			   ((string= (getf item :variable) "owner")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/zb/occurrence>")))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
+
 
 
 ;TODO: tms:scope, tms:value, complex filter

Modified: trunk/src/unit_tests/sparql_test.xtm
==============================================================================
--- trunk/src/unit_tests/sparql_test.xtm	(original)
+++ trunk/src/unit_tests/sparql_test.xtm	Fri Apr  1 09:30:30 2011
@@ -191,6 +191,7 @@
       <tm:value>Der Zauberlehrling</tm:value>
     </tm:name>
     <tm:occurrence>
+      <tm:itemIdentity href="http://some.where/ii/zb/occurrence"/>
       <tm:type><tm:topicRef href="#poem-content"/></tm:type>
       <tm:scope><tm:topicRef href="#de"/></tm:scope>
       <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">Hat der alte Hexenmeister



From lgiessmann at common-lisp.net  Fri Apr  1 13:57:59 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 09:57:59 -0400
Subject: [isidorus-cvs] r404 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q5erO-0005c5-Tu@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 09:57:58 2011
New Revision: 404

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri tms:value => fixed a bug when '<date>'^^xml-date is given

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_special_uris.lisp
   trunk/src/unit_tests/sparql_test.lisp
   trunk/src/unit_tests/sparql_test.xtm

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Fri Apr  1 09:57:58 2011
@@ -505,7 +505,8 @@
    Note the type xsd:date is not supported and so handled as a string."
   (declare (String literal-datatype))
   (let ((chars
-	 (cond ((string= literal-datatype *xml-string*)
+	 (cond ((or (string= literal-datatype *xml-string*)
+		    (string= literal-datatype *xml-date*))
 		(remove-if #'(lambda(elem)
 			       (string/= (charvalue elem) literal-value))
 			   (append

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Fri Apr  1 09:57:58 2011
@@ -255,7 +255,7 @@
 		    (not (variable-p obj)))
 	       (when (or (and (typep subj 'NameC)
 			      (string= literal-datatype *xml-string*)
-			      (string= (charvalue subj) (value obj)))
+			      (string= (charvalue (value subj)) (value obj)))
 			 (filter-datatypable-by-value subj obj literal-datatype))
 		 (list (list :subject subj-uri
 			     :predicate pred-uri
@@ -264,10 +264,10 @@
 	      ((not (variable-p subj))
 	       (list (list :subject subj-uri
 			   :predicate pred-uri
-			   :object (charvalue subj)
-			   :literal-datatype (if (typep subj 'd:NameC)
+			   :object (charvalue (value subj))
+			   :literal-datatype (if (typep (value subj) 'd:NameC)
 						 *xml-string*
-						 (datatype subj)))))
+						 (datatype (value subj))))))
 	      ((not (variable-p obj))
 	       (loop for char in (return-characteristics (value obj) literal-datatype)
 		  collect (list :subject (sparql-node char :revision revision)

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 09:57:58 2011
@@ -1882,12 +1882,55 @@
 	   r-1))))
 
 
+(test test-all-8
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/ii/goethe-untyped-name> tms:value ?obj1.
+                   <http://some.where/ii/goethe-occ> tms:value ?obj2.
+                   <http://some.where/ii/goethe-variant> tms:value ?obj3.
+                   ?subj1 tms:value 'Goethe'.
+                   ?subj2 tms:value '28.08.1749'^^http://www.w3.org/2001/XMLSchema#date.
+                   ?subj3 tms:value 'Johann Wolfgang von Goethe'.
+                   ?subj4 tms:value 82"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 7))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "obj1")
+			    (is (string= (first (getf item :result))
+					 "Johann Wolfgang von Goethe")))
+			   ((string= (getf item :variable) "obj2")
+			    (is (string= (first (getf item :result))
+					 "28.08.1749")))
+			   ((string= (getf item :variable) "obj3")
+			    (is (string= (first (getf item :result))
+					 "Goethe")))
+			   ((string= (getf item :variable) "subj1")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/goethe-variant>")))
+			   ((string= (getf item :variable) "subj2")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/goethe-occ>")))
+			   ((string= (getf item :variable) "subj3")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/goethe-untyped-name>")))
+			   ((string= (getf item :variable) "subj4")
+			    (is (string= (first (getf item :result))
+					 "<http://some.where/ii/goethe-years-occ>")))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
 
 
-;TODO: tms:scope, tms:value, complex filter
-;      <obj> <pred> <subj>
-;      ?obj <pred> ?subj
-;      <subj> ?pred ?obj
+;TODO: tms:value, complex filter,
+;      <obj> <pred> <subj>,
+;      ?obj <pred> ?subj,
+;      <subj> ?pred ?obj,
 ;      ?subj ?pred <obj>
 ;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
 ;      SELECT * WHERE {

Modified: trunk/src/unit_tests/sparql_test.xtm
==============================================================================
--- trunk/src/unit_tests/sparql_test.xtm	(original)
+++ trunk/src/unit_tests/sparql_test.xtm	Fri Apr  1 09:57:58 2011
@@ -141,6 +141,7 @@
       <tm:type><tm:topicRef href="#last-name"/></tm:type>
       <tm:value>von Goethe</tm:value>
       <tm:variant>
+	<tm:itemIdentity href="http://some.where/ii/goethe-variant"/>
 	<tm:scope><tm:topicRef href="#display-name"/></tm:scope>
 	<tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#string">Goethe</tm:resourceData>
       </tm:variant>
@@ -159,6 +160,7 @@
       <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#date">22.03.1832</tm:resourceData>
     </tm:occurrence>
     <tm:occurrence>
+      <tm:itemIdentity href="http://some.where/ii/goethe-years-occ"/>
       <tm:type><tm:topicRef href="#years"/></tm:type>
       <tm:resourceData datatype="http://www.w3.org/2001/XMLSchema#integer">82</tm:resourceData>
     </tm:occurrence>



From lgiessmann at common-lisp.net  Fri Apr  1 14:40:07 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 10:40:07 -0400
Subject: [isidorus-cvs] r405 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q5fWB-0000UO-Iv@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 10:40:07 2011
New Revision: 405

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri of the form <subj> <pred> <obj> => fixed a bug with names playing the role of object-resources

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_special_uris.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Fri Apr  1 10:40:07 2011
@@ -780,7 +780,9 @@
 		  subj pred (value (object construct))
 		  (literal-datatype (object construct)) :revision revision)))
 	      ((and (iri-p (object construct))
-		    (typep subj 'TopicC))
+		    (typep subj 'TopicC)
+		    (or (variable-p (object construct))
+			(typep (value (object construct)) 'TopicC)))
 	       (filter-associations subj pred (value (object construct))
 				    :revision revision)))))))
 

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Fri Apr  1 10:40:07 2011
@@ -253,14 +253,19 @@
 		     (literal-p obj)))
 	(cond ((and (not (variable-p subj))
 		    (not (variable-p obj)))
-	       (when (or (and (typep subj 'NameC)
-			      (string= literal-datatype *xml-string*)
+	       (if (typep (value subj) 'NameC)
+		   (when (and (string= literal-datatype *xml-string*)
 			      (string= (charvalue (value subj)) (value obj)))
-			 (filter-datatypable-by-value subj obj literal-datatype))
-		 (list (list :subject subj-uri
-			     :predicate pred-uri
-			     :object (value obj)
-			     :literal-datatype literal-datatype))))
+		     (list (list :subject subj-uri
+				 :predicate pred-uri
+				 :object (value obj)
+				 :literal-datatype literal-datatype)))
+		   (when (filter-datatypable-by-value (value subj) (value obj)
+						      literal-datatype)
+		     (list (list :subject subj-uri
+				 :predicate pred-uri
+				 :object (value obj)
+				 :literal-datatype literal-datatype)))))
 	      ((not (variable-p subj))
 	       (list (list :subject subj-uri
 			   :predicate pred-uri

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 10:40:07 2011
@@ -1926,9 +1926,28 @@
 	   r-1))))
 
 
+(test test-all-9
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/tmsparql/author/goethe> a <http://some.where/tmsparql/author>.
+	           <http://some.where/ii/goethe-occ> tms:reifier <http://some.where/ii/goethe-occ-reifier>.
+                   <http://some.where/ii/association> tms:role <http://some.where/ii/role-2>.
+                   <http://some.where/ii/role-2> tms:player <http://some.where/psis/poem/zauberlehrling>.
+                   <http://some.where/tmsparql/author/goethe> tms:topicProperty <http://some.where/ii/goethe-untyped-name>.
+                   <http://some.where/ii/goethe-variant> tms:scope <http://some.where/tmsparql/display-name>.
+                   <http://some.where/ii/goethe-untyped-name> tms:value 'Johann Wolfgang von Goethe'"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-false r-1))))
 
-;TODO: tms:value, complex filter,
-;      <obj> <pred> <subj>,
+
+
+
+;TODO: complex filter,
 ;      ?obj <pred> ?subj,
 ;      <subj> ?pred ?obj,
 ;      ?subj ?pred <obj>



From lgiessmann at common-lisp.net  Fri Apr  1 15:45:33 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 11:45:33 -0400
Subject: [isidorus-cvs] r406 - in trunk/src: model unit_tests
Message-ID: <E1Q5gXV-0005b1-2H@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 11:45:32 2011
New Revision: 406

Log:
TM-SPARQL: finsihed the unit-tests for the special-uri of the form ?var1 <pred> ?var2 => fixed a bug in get-db-instances-by-class

Modified:
   trunk/src/model/datamodel.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/model/datamodel.lisp
==============================================================================
--- trunk/src/model/datamodel.lisp	(original)
+++ trunk/src/model/datamodel.lisp	Fri Apr  1 11:45:32 2011
@@ -751,7 +751,8 @@
       (if revision
 	  (remove-null
 	   (map 'list #'(lambda(inst)
-			  (if (typep inst 'CHaracteristicC)
+			  (if (or (typep inst 'CharacteristicC)
+				  (typep inst 'RoleC))
 			      (find-item-by-revision inst revision
 						     (parent inst :revision revision))
 			      (find-item-by-revision inst revision)))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 11:45:32 2011
@@ -1852,7 +1852,8 @@
 				 "<http://some.where/tmsparql/author/goethe>")))
 			   ((string= (getf item :variable) "props")
 			    (is (= (length (getf item :result)) 8))
-			    (is-false (intersection prop-ids (getf item :result))))
+			    (is-false (set-exclusive-or prop-ids (getf item :result)
+							:test #'string=)))
 			   (t
 			    (is-true (format t "bad variable-name found")))))
 	   r-1))))
@@ -1945,10 +1946,123 @@
       (is-false r-1))))
 
 
+(test test-all-10
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   ?subj1 a ?obj1.
+                   ?subj2 tms:reifier ?obj2.
+                   ?subj3 tms:role ?obj3.
+                   ?subj4 tms:player ?obj4.
+                   ?subj5 tms:topicProperty ?obj5.
+                   ?subj6 tms:scope ?obj6.
+                   ?subj7 tms:value ?obj7"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is (= (length r-1) 14))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "subj1")
+			    (is (= (length (getf item :result)) 29)))
+			   ((string= (getf item :variable) "obj2")
+			    (is (= (length (getf item :result)) 4))
+			    (is-false (set-exclusive-or
+				       (getf item :result)
+				       (list "<http://some.where/ii/goethe-name-reifier>"
+					     "<http://some.where/ii/goethe-occ-reifier>"
+					     "<http://some.where/ii/association-reifier>"
+					     "<http://some.where/ii/role-reifier>")
+				       :test #'string=)))
+			   ((string= (getf item :variable) "subj3")
+			    (is (= (length (getf item :result)) 60))
+			    (is (find "<http://some.where/ii/association>"
+				      (getf item :result) :test #'string=)))
+			   ((string= (getf item :variable) "subj4")
+			    (is (= (length (getf item :result)) 60)))
+			   ((string= (getf item :variable) "subj5")
+			    (is (= (length (getf item :result)) 10)))
+			   ((string= (getf item :variable) "subj6")
+			    (is (= (length (getf item :result)) 2))
+			    (set-exclusive-or
+			     (getf item :result)
+			     (list "<http://some.where/ii/zb/occurrence>"
+				   "<http://some.where/ii/goethe-variant>")
+			     :test #'string=))
+			   ((string= (getf item :variable) "subj7")
+			    (is (= (length (getf item :result)) 11)))
+			   ((string= (getf item :variable) "obj1")
+			    (is (= (length (getf item :result)) 29)))
+			   ((string= (getf item :variable) "subj2")
+			    (is (= (length (getf item :result)) 4))
+			    (is-false
+			     (set-exclusive-or
+			      (getf item :result)
+			      (list
+			       "<http://some.where/ii/goethe-occ>"
+			       "<http://some.where/ii/association>"
+			       (concat
+				"_:r"
+				(write-to-string
+				 (elephant::oid
+				  (loop for role in
+				       (roles (get-item-by-item-identifier
+					       "http://some.where/ii/association"
+					       :revision 0) :revision 0)
+				     when (string=
+					   (uri (first
+						 (psis (player role :revision 0)
+						       :revision 0)))
+					   "http://some.where/tmsparql/author/goethe")
+				     return role))))
+			       (concat
+				"_:n"
+				(write-to-string
+				 (elephant::oid
+				  (loop for name in
+				       (names
+					(get-item-by-psi
+					 "http://some.where/tmsparql/author/goethe"
+					 :revision 0) :revision 0)
+				     when (string= (charvalue name) "von Goethe")
+				     return name)))))
+			      :test #'string=)))
+			   ((string= (getf item :variable) "obj3")
+			    (is (= (length (getf item :result)) 60))
+			    (is (find "<http://some.where/ii/role-2>"
+				      (getf item :result) :test #'string=)))
+			   ((string= (getf item :variable) "obj4")
+			    (is (= (length (getf item :result)) 60)))
+			   ((string= (getf item :variable) "obj5")
+			    (is (= (length (getf item :result)) 10)))
+			   ((string= (getf item :variable) "obj6")
+			    (is (= (length (getf item :result)) 2))
+			    (set-exclusive-or
+			     (getf item :result)
+			     (list "<http://some.where/tmsparql/display-name>"
+				   "<http://some.where/tmsparql/de>")))
+			   ((string= (getf item :variable) "obj7")
+			    (is (= (length (getf item :result)) 11))
+			    (set-exclusive-or
+			     (getf item :result)
+			     (list "Johann Wolfgang" "von Goethe"
+				   "Johann Wolfgang von Goethe" "Der Zauberlehrling"
+				   "28.08.1749" "22.03.1832" "82" "true" "false"
+				   "Hat der alte Hexenmeister
+	sich doch einmal wegbegeben!
+	...
+      ")
+			     :test #'string=))
+			    (t
+			     (is-true (format t "bad variable-name found")))))
+	   r-1))))
+
+
 
 
 ;TODO: complex filter,
-;      ?obj <pred> ?subj,
+;      complex relations between variables
 ;      <subj> ?pred ?obj,
 ;      ?subj ?pred <obj>
 ;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/>



From lgiessmann at common-lisp.net  Fri Apr  1 16:52:05 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 12:52:05 -0400
Subject: [isidorus-cvs] r407 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q5hZt-0002RX-CC@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 12:52:05 2011
New Revision: 407

Log:
TM-SPARQL: fixed a bug in the setter for elem-type (SPARQL-Triple-Elem)

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_special_uris.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Fri Apr  1 12:52:05 2011
@@ -242,17 +242,17 @@
     (push triple (slot-value construct 'select-group))))
 
 
-(defgeneric (setf elem-type) (construct elem-type)
+(defgeneric (setf elem-type) (value construct)
   (:documentation "Sets the passed elem-type on the passed cosntruct.")
-  (:method ((construct SPARQL-Triple-Elem) (elem-type Symbol))
-    (when (and (not (eql elem-type 'IRI))
-	       (not (eql elem-type 'VARIABLE))
-	       (not (eql elem-type 'LITERAL)))
+  (:method ((value Symbol) (construct SPARQL-Triple-Elem))
+    (when (and (not (eql value 'IRI))
+	       (not (eql value 'VARIABLE))
+	       (not (eql value 'LITERAL)))
       (error (make-condition
 	      'bad-argument-error
 	      :message (format nil "Expected a one of the symbols ~a, but get ~a~%"
-			       '('IRI 'VARIABLE 'LITERAL) elem-type))))
-    (setf (slot-value construct 'elem-type) elem-type)))
+			       '('IRI 'VARIABLE 'LITERAL) value))))
+    (setf (slot-value construct 'elem-type) value)))
 
 
 (defgeneric add-prefix (construct prefix-label prefix-value)
@@ -771,9 +771,9 @@
 	(cond ((variable-p (object construct))
 	       (when (typep subj 'TopicC)
 		 (append (filter-characteristics
-			  subj pred nil nil :revision revision)
-			 (filter-associations
-			  subj pred nil :revision revision))))
+				     subj pred nil nil :revision revision)
+				    (filter-associations
+				     subj pred nil :revision revision))))
 	      ((literal-p (object construct))
 	       (when (typep subj 'TopicC)
 		 (filter-characteristics

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Fri Apr  1 12:52:05 2011
@@ -58,6 +58,7 @@
                    and its objects corresponding to the defined
                    special-uris, e.g. <subj> var <obj>.")
   (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (setf (elem-type (predicate construct)) 'IRI)
     (let* ((pred (predicate construct))
 	   (old-pred-value (value pred))
 	   (res-1
@@ -90,6 +91,7 @@
 	      (let ((val (filter-for-player construct :revision revision)))
 		(setf (value pred) old-pred-value)
 		val))))
+      (setf (elem-type (predicate construct)) 'VARIABLE)
       (append res-1 res-2 res-3 res-4 res-5))))
 
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 12:52:05 2011
@@ -2059,6 +2059,24 @@
 	   r-1))))
 
 
+(test test-all-11
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
+		   <http://some.where/ii/association> ?pred2 ?obj2.
+                   <http://some.where/ii/role-2> ?pred3 ?obj3.
+                   <http://some.where/ii/goethe-untyped-name> ?pred4 ?obj4.
+                   <http://some.where/ii/goethe-occ> ?pred5 ?obj5.
+                   <http://some.where/ii/goethe-variant> ?pred6 ?obj6"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 12))
+      (format t "~a~%" r-1))))
+
 
 
 ;TODO: complex filter,



From lgiessmann at common-lisp.net  Fri Apr  1 18:36:47 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 14:36:47 -0400
Subject: [isidorus-cvs] r408 - trunk/src/unit_tests
Message-ID: <E1Q5jDD-0002FJ-IA@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 14:36:47 2011
New Revision: 408

Log:
fixed a svn problem

Modified:
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  1 14:36:47 2011
@@ -2075,6 +2075,7 @@
                  "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
       (is-true (= (length r-1) 12))
+      
       (format t "~a~%" r-1))))
 
 



From lgiessmann at common-lisp.net  Fri Apr  1 19:10:07 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 01 Apr 2011 15:10:07 -0400
Subject: [isidorus-cvs] r409 - trunk/src/TM-SPARQL
Message-ID: <E1Q5jjT-000551-BR@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  1 15:10:07 2011
New Revision: 409

Log:
TM-SPARQL: fixed a bug in the macro with-triple-nodes that appears with the latest changes with special-uris

Modified:
   trunk/src/TM-SPARQL/sparql_special_uris.lisp

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Fri Apr  1 15:10:07 2011
@@ -18,12 +18,15 @@
   `(let* ((subj (subject ,triple-construct))
 	  (pred (predicate ,triple-construct))
 	  (obj (object ,triple-construct))
-	  (subj-uri (unless (variable-p subj)
+	  (subj-uri (when (and (not (variable-p subj))
+			       (value subj))
 		      (sparql-node (value subj) :revision revision)))
-	  (pred-uri (unless (variable-p pred)
+	  (pred-uri (when (and (not (variable-p pred))
+			       (value pred))
 		      (sparql-node (value pred) :revision revision)))
 	  (obj-uri (when (and (not (variable-p obj))
-			      (not (literal-p obj)))
+			      (not (literal-p obj))
+			      (value obj))
 		     (sparql-node (value obj) :revision revision)))
 	  (literal-datatype (when (literal-p obj)
 			      (literal-datatype obj))))
@@ -386,7 +389,7 @@
 			      (get-all-topics revision)))))
 		   (loop for top in topics
 		      collect (list :subject
-				    (sparql-node (reified-construct top :revision revision)
-						 :revision revision)
-				    :predicate pred-uri
-				    :object (sparql-node top :revision revision)))))))))))
\ No newline at end of file
+					(sparql-node (reified-construct top :revision revision)
+						     :revision revision)
+					:predicate pred-uri
+					:object (sparql-node top :revision revision)))))))))))
\ No newline at end of file



From lgiessmann at common-lisp.net  Sun Apr  3 19:56:16 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sun, 03 Apr 2011 15:56:16 -0400
Subject: [isidorus-cvs] r410 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q6TPE-0002oQ-2O@common-lisp.net>

Author: lgiessmann
Date: Sun Apr  3 15:56:15 2011
New Revision: 410

Log:
TM-SPARQL: fixed a bug in the processing of final results when making intersections of all triples containing the same variable; finished the unit-tests for triples of the form <subj> ?var1 ?var2

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sun Apr  3 15:56:15 2011
@@ -576,10 +576,11 @@
 			  (pred-uri
 			   (when-do top (instance-of char :revision revision)
 				    (sparql-node top :revision revision))))
-		      (list :subject subj-uri
-			    :predicate pred-uri
-			    :object (charvalue char)
-			    :literal-datatype literal-datatype)))
+		      (when (and subj-uri pred-uri)
+			(list :subject subj-uri
+			      :predicate pred-uri
+			      :object (charvalue char)
+			      :literal-datatype literal-datatype))))
 	  (remove-if #'(lambda(char)
 			 (typep char 'VariantC))
 		     (return-characteristics literal-value literal-datatype)))))
@@ -602,13 +603,14 @@
 					 2)
 				  (find-if #'(lambda(r) (not (eql r role)))
 					   (roles assoc :revision revision))))))
-		  (list :subject
-			(when-do plr (player orole :revision revision)
-				 (sparql-node plr :revision revision))
-			:predicate
-			(when-do type (instance-of role :revision revision)
-				 (sparql-node type :revision revision))
-			:object obj-uri)))
+		  (when orole
+		    (list :subject
+			  (when-do plr (player orole :revision revision)
+				   (sparql-node plr :revision revision))
+			  :predicate
+			  (when-do type (instance-of role :revision revision)
+				   (sparql-node type :revision revision))
+			  :object obj-uri))))
 	    roles-by-oplayer)))))
 
 
@@ -664,15 +666,16 @@
 				  (find-if #'(lambda(r)
 					       (not (eql r role)))
 					   (roles assoc :revision revision)))))
-		    (list :subject
-			  (when-do plr (player orole :revision revision)
-				   (sparql-node plr :revision revision))
-			  :predicate
-			  (sparql-node (value (predicate construct))
-						 :revision revision)
-			  :object
-			  (when-do plr-top (player role :revision revision)
-				   (sparql-node plr-top :revision revision)))))
+		    (when (and orole assoc)
+		      (list :subject
+			    (when-do plr (player orole :revision revision)
+				     (sparql-node plr :revision revision))
+			    :predicate
+			    (sparql-node (value (predicate construct))
+					 :revision revision)
+			    :object
+			    (when-do plr-top (player role :revision revision)
+				     (sparql-node plr-top :revision revision))))))
 	      roles-by-player))))))
 
 
@@ -711,14 +714,16 @@
 	(remove-null
 	 (map 'list
 	      #'(lambda(name)
-		  (list :subject
-			(when-do top (parent name :revision revision)
-				 (sparql-node top :revision revision))
-			:predicate
-			(when-do top (instance-of name :revision revision)
-				 (sparql-node top :revision revision))
-			:object (charvalue name)
-			:literal-datatype *xml-string*))
+		  (when (and (parent name :revision revision)
+			     (instance-of name :revision revision))
+		    (list :subject
+			  (sparql-node (parent name :revision revision)
+				       :revision revision)
+			  :predicate
+			  (sparql-node (instance-of name :revision revision)
+				       :revision revision)
+			  :object (charvalue name)
+			  :literal-datatype *xml-string*)))
 	      names-by-literal))))))
 
 
@@ -748,14 +753,16 @@
 	(remove-null
 	 (map 'list
 	      #'(lambda(occ)
-		  (list :subject
-			(when-do top (parent occ :revision revision)
-				 (sparql-node top :revision revision))
-			:predicate
-			(when-do top (instance-of occ :revision revision)
-				 (sparql-node top :revision revision))
-			:object (charvalue occ)
-			:literal-datatype (datatype occ)))
+		  (when (and (parent occ :revision revision)
+			     (instance-of occ :revision revision))
+		    (list :subject
+			  (sparql-node (parent occ :revision revision)
+				       :revision revision)
+			  :predicate
+			  (sparql-node (instance-of occ :revision revision)
+				       :revision revision)
+			  :object (charvalue occ)
+			  :literal-datatype (datatype occ))))
 	      all-occs))))))
 
 
@@ -771,9 +778,9 @@
 	(cond ((variable-p (object construct))
 	       (when (typep subj 'TopicC)
 		 (append (filter-characteristics
-				     subj pred nil nil :revision revision)
-				    (filter-associations
-				     subj pred nil :revision revision))))
+			  subj pred nil nil :revision revision)
+			 (filter-associations
+			  subj pred nil :revision revision))))
 	      ((literal-p (object construct))
 	       (when (typep subj 'TopicC)
 		 (filter-characteristics
@@ -937,13 +944,13 @@
 	   (subj-uri (sparql-node construct :revision revision)))
       (remove-null
        (map 'list #'(lambda(occ)
-		      (list :subject subj-uri
-			    :predicate
-			    (when-do type-top
-				     (instance-of occ :revision revision)
-				     (sparql-node type-top :revision revision))
-			    :object (charvalue occ)
-			    :literal-datatype (datatype occ)))
+		      (when (instance-of occ :revision revision)
+			(list :subject subj-uri
+			      :predicate (sparql-node
+					  (instance-of occ :revision revision)
+					  :revision revision)
+			      :object (charvalue occ)
+			      :literal-datatype (datatype occ))))
 	    all-occs)))))
 
 
@@ -968,15 +975,15 @@
 			   (names construct :revision revision)))
 	   (all-names (intersection by-type by-literal))
 	   (subj-uri (sparql-node construct :revision revision)))
-      (remove-null
-       (map 'list #'(lambda(name)
-		      (list :subject subj-uri
-			    :predicate
-			    (when-do type-top (instance-of name :revision revision)
-				     (sparql-node type-top :revision revision))
-			    :object (charvalue name)
-			    :literal-datatype *xml-string*))
-	    all-names)))))
+      (map 'list #'(lambda(name)
+		     (when (instance-of name :revision revision)
+		       (list :subject subj-uri
+			     :predicate (sparql-node
+					 (instance-of name :revision revision)
+					 :revision revision)
+			     :object (charvalue name)
+			     :literal-datatype *xml-string*)))
+	   all-names))))
 
 
 (defgeneric filter-characteristics (construct type-top literal-value
@@ -1037,9 +1044,10 @@
 			    (when-do player-top (player other-role
 							:revision revision)
 				     (sparql-node player-top :revision revision)))))
-		    (list :subject subj-uri
-			  :predicate pred-uri
-			  :object obj-uri))))
+		    (when (and subj-uri pred-uri obj-uri)
+		      (list :subject subj-uri
+			    :predicate pred-uri
+			    :object obj-uri)))))
 	    assocs)))))
 
 
@@ -1065,6 +1073,8 @@
     (remove-null
      (loop for triple in (select-group construct)
 	append (remove-null
+		;;TODO: replace remove-null by a function that check if any of the
+                ;;      list items is nil, if so the entire list should be nil
 		(list
 		 (when (variable-p (subject triple))
 		   (list :variable (value (subject triple))
@@ -1102,7 +1112,7 @@
 (defgeneric variable-intersection (variable-name result-lists)
   (:documentation "Returns a list with all results of the passed variable
                    that are contained in the result-lists. All results is
-                   an intersection of all paratial results.")
+                   an intersection of all partial results.")
   (:method ((variable-name String) (result-lists List))
     (let* ((all-values (results-for-variable variable-name result-lists))
 	   (list-1 (when (>= (length all-values) 1)
@@ -1135,7 +1145,7 @@
   (:method ((construct SPARQL-Query) (result-lists List))
     (map 'list #'(lambda(triple)
 		   (reduce-triple triple result-lists))
-	 (select-group construct))))
+    (select-group construct))))
 
 
 (defgeneric reduce-triple(construct result-lists)
@@ -1155,6 +1165,7 @@
 	   intersections))))
 
 
+
 (defgeneric delete-rows (construct variable-name dont-touch-values)
   (:documentation "Checks all results of the passed variable of the given
                    construct and deletes every result with the corresponding
@@ -1173,17 +1184,15 @@
 		  (object-result construct)))))
       (when var-elem
 	(let* ((rows-to-hold
-		(remove-null
-		 (map 'list #'(lambda(res)
-				(when (cond
-					((stringp res)
-					 (find res dont-touch-values :test #'string=))
-					((numberp res)
-					 (find res dont-touch-values :test #'=))
-					(t
-					 (find res dont-touch-values)))
-				  (position res var-elem)))
-		      var-elem)))
+		(loop for idx to (max 0 (1- (length var-elem)))
+		   when  (cond
+			   ((stringp (elt var-elem idx))
+			    (find (elt var-elem idx) dont-touch-values :test #'string=))
+			   ((numberp (elt var-elem idx))
+			    (find (elt var-elem idx) dont-touch-values :test #'=))
+			   (t
+			    (find (elt var-elem idx) dont-touch-values)))
+		   collect idx))
 	       (new-result-list
 		(map 'list
 		     #'(lambda(row-idx)

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sun Apr  3 15:56:15 2011
@@ -16,7 +16,8 @@
 	 :unittests-constants
 	 :fixtures
 	 :d
-	 :constants)
+	 :constants
+	 :tm-sparql-constants)
   (:export :run-sparql-tests
 	   :sparql-tests
 	   :test-prefix-and-base
@@ -2075,14 +2076,105 @@
                  "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
       (is-true (= (length r-1) 12))
-      
-      (format t "~a~%" r-1))))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "pred1")
+			    ;one name without a type so it is not listed
+			    (is (= (length (getf item :result)) 9)))
+			   ((string= (getf item :variable) "pred2")
+			    (is (= (length (getf item :result)) 3))
+			    (is-false (set-exclusive-or
+				       (getf item :result)
+				       (list (concat "<" *tms-role* ">")
+					     (concat "<" *tms-reifier* ">"))
+				       :test #'string=)))
+			   ((string= (getf item :variable) "pred3")
+			    (is (= (length (getf item :result)) 1))
+			    (is (string= (first (getf item :result))
+					 (concat "<" *tms-player* ">"))))
+			   ((string= (getf item :variable) "pred4")
+			    (is (= (length (getf item :result)) 1))
+			    (is (string= (first (getf item :result))
+					 (concat "<" *tms-value* ">"))))
+			   ((string= (getf item :variable) "pred5")
+			    (is (= (length (getf item :result)) 2))
+			    (is-false (set-exclusive-or
+				       (getf item :result)
+				       (list (concat "<" *tms-value* ">")
+					     (concat "<" *tms-reifier* ">"))
+				       :test #'string=)))
+			   ((string= (getf item :variable) "pred6")
+			    (is (= (length (getf item :result)) 2))
+			    (is-false (set-exclusive-or
+				       (getf item :result)
+				       (list (concat "<" *tms-value* ">")
+					     (concat "<" *tms-scope* ">"))
+				       :test #'string=)))
+			   ((string= (getf item :variable) "obj1")
+			    (is (= (length (getf item :result)) 9))
+			    (is-false (set-exclusive-or
+				       (getf item :result)
+				       (list "Johann Wolfgang" "von Goethe"
+					     "28.08.1749" "22.03.1832" "82"
+					     "true" "false"
+					     "<http://some.where/tmsparql/author>"
+					     "<http://some.where/psis/poem/zauberlehrling>")
+				       :test #'string=)))
+			   ((string= (getf item :variable) "obj2")
+			    (is (= (length (getf item :result)) 3))
+			    (is-false
+			     (set-exclusive-or
+			      (getf item :result)
+			      (list
+			       "<http://some.where/ii/association-reifier>"
+			       "<http://some.where/ii/role-2>"
+			       (concat
+				"_:r"
+				(write-to-string
+				 (elephant::oid
+				  (loop for role in
+				       (roles
+					(get-item-by-item-identifier
+					 "http://some.where/ii/association"
+					 :revision 0))
+				     when (string=
+					   (uri (first (psis (player role
+								     :revision 0))))
+					   "http://some.where/tmsparql/author/goethe")
+				     return role)))))
+			      :test #'string=)))
+			   ((string= (getf item :variable) "obj3")
+			    (is (= (length (getf item :result)) 1))
+			    (is (string=
+				 (first (getf item :result))
+				 "<http://some.where/psis/poem/zauberlehrling>")))
+			   ((string= (getf item :variable) "obj4")
+			    (is (= (length (getf item :result)) 1))
+			    (is (string= (first (getf item :result))
+					 "Johann Wolfgang von Goethe")))
+			   ((string= (getf item :variable) "obj5")
+			    (is (= (length (getf item :result)) 2))
+			    (is-false
+			     (set-exclusive-or
+			      (getf item :result)
+			      (list "28.08.1749"
+				    "<http://some.where/ii/goethe-occ-reifier>")
+			      :test #'string=)))
+			   ((string= (getf item :variable) "obj6")
+			   (is (= (length (getf item :result)) 2))
+			    (is-false
+			     (set-exclusive-or
+			      (getf item :result)
+			      (list "Goethe"
+				    "<http://some.where/tmsparql/display-name>")
+			      :test #'string=)))
+			   (t
+			    (is-true (format t "bad variable-name found")))))
+	   r-1))))
 
 
 
 ;TODO: complex filter,
 ;      complex relations between variables
-;      <subj> ?pred ?obj,
 ;      ?subj ?pred <obj>
 ;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
 ;      SELECT * WHERE {



From lgiessmann at common-lisp.net  Sun Apr  3 21:12:19 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Sun, 03 Apr 2011 17:12:19 -0400
Subject: [isidorus-cvs] r411 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q6Uap-0007kU-4o@common-lisp.net>

Author: lgiessmann
Date: Sun Apr  3 17:12:18 2011
New Revision: 411

Log:
TM-SPARQL: fixed a bug in the processing of the property tms:topicProperty; finished the unit-tests for triples of the form ?var1 ?var2 <obj>

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_special_uris.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Sun Apr  3 17:12:18 2011
@@ -495,7 +495,8 @@
 	     (filter-by-characteristic-value (value (object construct))
 					     (literal-datatype (object construct))
 					     :revision revision))
-	    ((iri-p (object construct))
+	    ((and (iri-p (object construct))
+		  (typep (value (object construct)) 'TopicC))
 	     (filter-by-otherplayer (value (object construct))
 				    :revision revision))))))
 
@@ -1073,8 +1074,6 @@
     (remove-null
      (loop for triple in (select-group construct)
 	append (remove-null
-		;;TODO: replace remove-null by a function that check if any of the
-                ;;      list items is nil, if so the entire list should be nil
 		(list
 		 (when (variable-p (subject triple))
 		   (list :variable (value (subject triple))

Modified: trunk/src/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_special_uris.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_special_uris.lisp	Sun Apr  3 17:12:18 2011
@@ -93,9 +93,16 @@
 	      (setf (value pred) (get-item-by-psi *tms-player* :revision revision))
 	      (let ((val (filter-for-player construct :revision revision)))
 		(setf (value pred) old-pred-value)
+		val)))
+	   (res-6
+	    (progn
+	      (setf (value pred) (get-item-by-psi *tms-topicProperty*
+						  :revision revision))
+	      (let ((val (filter-for-topicProperties construct :revision revision)))
+		(setf (value pred) old-pred-value)
 		val))))
       (setf (elem-type (predicate construct)) 'VARIABLE)
-      (append res-1 res-2 res-3 res-4 res-5))))
+      (append res-1 res-2 res-3 res-4 res-5 res-6))))
 
 
 (defgeneric filter-for-player (construct &key revision)

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Sun Apr  3 17:12:18 2011
@@ -2079,7 +2079,7 @@
       (map 'list #'(lambda(item)
 		     (cond ((string= (getf item :variable) "pred1")
 			    ;one name without a type so it is not listed
-			    (is (= (length (getf item :result)) 9)))
+			    (is (= (length (getf item :result)) 17)))
 			   ((string= (getf item :variable) "pred2")
 			    (is (= (length (getf item :result)) 3))
 			    (is-false (set-exclusive-or
@@ -2110,15 +2110,26 @@
 					     (concat "<" *tms-scope* ">"))
 				       :test #'string=)))
 			   ((string= (getf item :variable) "obj1")
-			    (is (= (length (getf item :result)) 9))
-			    (is-false (set-exclusive-or
-				       (getf item :result)
-				       (list "Johann Wolfgang" "von Goethe"
-					     "28.08.1749" "22.03.1832" "82"
-					     "true" "false"
-					     "<http://some.where/tmsparql/author>"
-					     "<http://some.where/psis/poem/zauberlehrling>")
-				       :test #'string=)))
+			    (is (= (length (getf item :result)) 17))
+			    (is-true (find "Johann Wolfgang" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "von Goethe" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "true" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "false" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "28.08.1749" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "22.03.1832" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "82" (getf item :result)
+					   :test #'string=))
+			    (is-true (find "<http://some.where/tmsparql/author>"
+					   (getf item :result) :test #'string=))
+			    (is-true
+			     (find "<http://some.where/psis/poem/zauberlehrling>"
+				   (getf item :result) :test #'string=)))
 			   ((string= (getf item :variable) "obj2")
 			    (is (= (length (getf item :result)) 3))
 			    (is-false
@@ -2172,10 +2183,124 @@
 	   r-1))))
 
 
+(test test-all-12
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
+                  SELECT * WHERE {
+                   ?subj1 ?pred1 <http://some.where/tmsparql/author/goethe>.
+                   ?subj2 ?pred2 <http://some.where/ii/goethe-variant>.
+                   ?subj3 ?pred3 <http://some.where/ii/goethe-untyped-name>.
+                   ?subj4 ?pred4 <http://some.where/ii/goethe-occ>.
+                   ?subj5 ?pred5 <http://some.where/ii/association>.
+                   ?subj6 ?pred6 <http://some.where/ii/role-2>.
+                   ?subj7 ?pred7 <http://some.where/tmsparql/display-name>.
+                   ?subj8 ?pred8 <http://some.where/ii/role-reifier>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 16))
+      (map 'list #'(lambda(item)
+		     (cond ((string= (getf item :variable) "pred1")
+			    (is (= (length (getf item :result)) 4))
+			    (is-false
+			     (set-exclusive-or
+			      (list (concat "<" *instance-psi* ">")
+				    "<http://some.where/tmsparql/writer>"
+				    (concat "<" *tms-player* ">"))
+			      (getf item :result) :test #'string=)))
+			   ((string= (getf item :variable) "obj1")
+			    (is (= (length (getf item :result)) 4))
+			    (is-false
+			     (set-exclusive-or
+			      (list "<http://some.where/tmsparql/author>"
+				    "<http://some.where/psis/poem/zauberlehrling>"
+				    (concat
+				     "_:r"
+				     (write-to-string
+				      (elephant::oid
+				       (first
+					(player-in-roles
+					 (get-item-by-psi
+					  "http://some.where/tmsparql/author/goethe"
+					  :revision 0) :revision 0)))))
+				    (concat
+				     "_:r"
+				     (write-to-string
+				      (elephant::oid
+				       (second
+					(player-in-roles
+					 (get-item-by-psi
+					  "http://some.where/tmsparql/author/goethe"
+					  :revision 0) :revision 0))))))
+			      (getf item :result) :test #'string=)))
+			    ((or (string= (getf item :variable) "pred2")
+				 (string= (getf item :variable) "pred5"))
+			     (is-false (getf item :result)))
+			    ((or (string= (getf item :variable) "subj2")
+				 (string= (getf item :variable) "obj5"))
+			     (is-false (getf item :result)))
+			    ((or (string= (getf item :variable) "pred3")
+				 (string= (getf item :variable) "pred4"))
+			     (is (= (length (getf item :result)) 1))
+			     (is (string= (first (getf item :result))
+					  (concat "<" *tms-topicProperty* ">"))))
+			    ((or (string= (getf item :variable) "subj3")
+				 (string= (getf item :variable) "obj4"))
+			     (is (= (length (getf item :result)) 1))
+			     (is (string= (first (getf item :result))
+					  "<http://some.where/tmsparql/author/goethe>")))
+			    ((string= (getf item :variable) "pred6")
+			     (is (= (length (getf item :result)) 1))
+			     (is (string= (first (getf item :result))
+					  (concat "<" *tms-role* ">"))))
+			    ((string= (getf item :variable) "subj6")
+			     (is (= (length (getf item :result)) 1))
+			     (is (string= (first (getf item :result))
+					  "<http://some.where/ii/association>")))
+			    ((string= (getf item :variable) "pred7")
+			     (is (= (length (getf item :result)) 3))
+			     (is-false (set-exclusive-or
+					(list (concat "<" *tms-player* ">")
+					      (concat "<" *tms-scope* ">")
+					      (concat "<" *instance-psi* ">"))
+					(getf item :result) :test #'string=)))
+			    ((string= (getf item :variable) "subj7")
+			     (is (= (length (getf item :result)) 3))
+			     (is (find "<http://psi.topicmaps.org/tmcl/scope-type>"
+				       (getf item :result) :test #'string=))
+			     (is (find "<http://some.where/ii/goethe-variant>"
+				       (getf item :result) :test #'string=)))
+			    ((string= (getf item :variable) "pred8")
+			     (is (= (length (getf item :result)) 3))
+			     (is-false (set-exclusive-or
+					(list (concat "<" *tms-player* ">")
+					      (concat "<" *tms-reifier* ">")
+					      (concat "<" *instance-psi* ">"))
+					(getf item :result) :test #'string=)))
+			    ((string= (getf item :variable) "subj8")
+			     (is (= (length (getf item :result)) 3))
+			     (set-exclusive-or
+			      (list "http://some.where/tmsparql/reifier-type"
+				    (concat
+				     "_:r"
+				     (write-to-string
+				      (elephant::oid
+				       (first
+					(player-in-roles
+					 (get-item-by-item-identifier
+					  "http://some.where/ii/role-reifier"
+					  :revision 0) :revision 0))))))
+			      (getf item :result) :test #'string=))))
+	   r-1))))
+
+
+
+
 
-;TODO: complex filter,
-;      complex relations between variables
-;      ?subj ?pred <obj>
+;TODO: test complex filters,
+;      test complex relations between variables
 ;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
 ;      SELECT * WHERE {
 ;        ?assoc tms:reifier <http://some.where/ii/association-reifier>.



From lgiessmann at common-lisp.net  Mon Apr  4 08:50:25 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Mon, 04 Apr 2011 04:50:25 -0400
Subject: [isidorus-cvs] r412 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q6fUP-0000uJ-HT@common-lisp.net>

Author: lgiessmann
Date: Mon Apr  4 04:50:25 2011
New Revision: 412

Log:
TM-SPARQL: fixed a bug in the processing of final results when creating result-intersections and finished a unit-tests for such a scenario

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Mon Apr  4 04:50:25 2011
@@ -1080,7 +1080,7 @@
 			 :result (subject-result triple)))
 		 (when (variable-p (predicate triple))
 		   (list :variable (value (predicate triple))
-			  :result (predicate-result triple)))
+			 :result (predicate-result triple)))
 		 (when (variable-p (object triple))
 		   (list :variable (value (object triple))
 			 :result (object-result triple)))))))))
@@ -1116,7 +1116,7 @@
     (let* ((all-values (results-for-variable variable-name result-lists))
 	   (list-1 (when (>= (length all-values) 1)
 		     (first all-values)))
-	   (list-2 (if (> (length all-values) 2)
+	   (list-2 (if (>= (length all-values) 2)
 		       (second all-values)
 		       list-1))
 	   (more-lists (rest (rest all-values))))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Mon Apr  4 04:50:25 2011
@@ -2079,6 +2079,7 @@
       (map 'list #'(lambda(item)
 		     (cond ((string= (getf item :variable) "pred1")
 			    ;one name without a type so it is not listed
+			    ;as regular triple but as tms:topicProperty
 			    (is (= (length (getf item :result)) 17)))
 			   ((string= (getf item :variable) "pred2")
 			    (is (= (length (getf item :result)) 3))
@@ -2297,17 +2298,49 @@
 
 
 
+(test test-all-13
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "PREFIX tms:<" *tms* ">
+                  SELECT * WHERE {
+                   ?assoc tms:reifier <http://some.where/ii/association-reifier>.
+                   ?assoc tms:role ?roles.
+                   ?roles tms:reifier <http://some.where/ii/role-reifier>"
+                 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      (is-true (= (length r-1) 2))
+      (map 'list #'(lambda(item)
+		     (cond
+		       ((string= (getf item :variable) "assoc")
+			(is (= (length (getf item :result)) 1))
+			(is (string= (first (getf item :result))
+				     "<http://some.where/ii/association>")))
+		       ((string= (getf item :variable) "roles")
+			(is (= (length (getf item :result)) 1))
+			(is
+			 (string=
+			  (first (getf item :result))
+			  (concat
+			   "_:r"
+			   (write-to-string
+			    (elephant::oid
+			     (loop for role in
+				  (roles
+				   (get-item-by-item-identifier
+				    "http://some.where/ii/association"
+				    :revision 0) :revision 0)
+				when (string=
+				      (uri (first (psis (player role :revision 0)
+							:revision 0)))
+				      "http://some.where/tmsparql/author/goethe")
+				return role)))))))))
+	   r-1))))
 
 
-;TODO: test complex filters,
-;      test complex relations between variables
-;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/>
-;      SELECT * WHERE {
-;        ?assoc tms:reifier <http://some.where/ii/association-reifier>.
-;        ?assoc tms:role ?roles}
-; => ?assoc = http://some.where/ii/association
-; => ?roles = (http://some.where/ii/role-2, _:r????)
 
+;TODO: test complex filters
 
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Tue Apr  5 09:31:40 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 05 Apr 2011 05:31:40 -0400
Subject: [isidorus-cvs] r413 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1Q72bs-0003aG-Fu@common-lisp.net>

Author: lgiessmann
Date: Tue Apr  5 05:31:40 2011
New Revision: 413

Log:
changed the behavior of the handling of paranthesis and quotations in filters and the behavior of hanlding SPARQL comments

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Tue Apr  5 05:31:40 2011
@@ -377,6 +377,9 @@
   (:documentation "Processes all filters by calling invoke-filter.")
   (:method ((construct SPARQL-Query))
     (dolist (filter (filters construct))
+
+      (format t ">>>~a<<<~%" filter) ;TODO: remove
+
       (let* ((filter-variable-names
 	      (get-variables-from-filter-string filter))
 	     (filter-variable-values nil)

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Tue Apr  5 05:31:40 2011
@@ -38,7 +38,10 @@
     (if (string-starts-with trimmed-str "#")
         (let ((next-query (string-after trimmed-str (string #\newline))))
 	  (if next-query
-	      next-query
+	      (let ((cleaned-next-query (cut-comment next-query)))
+		(if (string= next-query cleaned-next-query)
+		    next-query
+		    (cut-comment next-query)))
 	      ""))
 	trimmed-str)))
 

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Tue Apr  5 05:31:40 2011
@@ -437,25 +437,35 @@
 	   (Integer pos))
   (let ((result nil))
     (dotimes (idx (length filter-string) result)
-      (let ((current-char (subseq filter-string idx (1+ idx))))
-	(cond ((or (string= current-char "'")
-		   (string= current-char "\""))
-	       (let* ((l-result (get-literal (subseq filter-string idx)))
-		      (next-idx
-		       (when l-result
-			 (- (length filter-string)
-			    (length (getf l-result :next-string))))))
-		 (when (and next-idx (< pos next-idx))
-		   (setf result t)
-		   (setf idx (length filter-string)))
-		 (when (<= pos idx)
-		   (setf idx (length filter-string)))))
-	      (t
-	       (when (<= pos idx)
-		 (setf idx (length filter-string)))))))))
+      (let* ((current-str (subseq filter-string idx))
+	     (delimiter (cond ((string-starts-with current-str "'''")
+			       "'''")
+			      ((string-starts-with current-str "'")
+			       "'")
+			      ((string-starts-with current-str "\"\"\"")
+			       "\"\"\"")
+			      ((string-starts-with current-str "\"")
+			       "\""))))
+	(when delimiter
+	  (let* ((end-pos
+		  (let ((result
+			 (search-first (list delimiter) 
+				       (subseq current-str (length delimiter)))))
+		    (when result
+		      (+ (length delimiter) result))))
+		 (quoted-str (when end-pos
+			       (subseq current-str (length delimiter) end-pos)))
+		 (start-pos idx))
+	    (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))
+	    (if (and (>= pos start-pos)
+		     (<= pos (+ start-pos end-pos)))
+		(progn
+		  (setf result t)
+		  (setf idx (length filter-string)))
+		(incf idx (+ (* 2 (length delimiter)) (length quoted-str))))))))))
 
 
-(defun search-first-unclosed-paranthesis (str &key ignore-literals)
+(defun search-first-unclosed-paranthesis (str &key (ignore-literals t))
   "Returns the idx of the first ( that is not closed, the search is
    started from the end of the string.
    If ignore-literals is set to t all paranthesis that are within
@@ -467,12 +477,14 @@
     (do ((idx (1- (length str)))) ((< idx 0))
       (let ((current-char (subseq str idx (1+ idx))))
 	(cond ((string= current-char ")")
-	       (when (or ignore-literals
-			 (not (in-literal-string-p str idx)))
+	       (when (or (not ignore-literals)
+			 (and ignore-literals
+			      (not (in-literal-string-p str idx))))
 		 (decf open-brackets)))
 	      ((string= current-char "(")
-	       (when (or ignore-literals
-			 (not (in-literal-string-p str idx)))
+	       (when (or (not ignore-literals)
+			 (and ignore-literals
+			      (not (in-literal-string-p str idx))))
 		 (incf open-brackets)
 		 (when (> open-brackets 0)
 		   (setf result-idx idx)
@@ -481,7 +493,7 @@
     result-idx))
 
 
-(defun search-first-unopened-paranthesis (str &key ignore-literals)
+(defun search-first-unopened-paranthesis (str &key (ignore-literals t))
   "Returns the idx of the first paranthesis that is not opened in str.
    If ignore-literals is set to t all mparanthesis that are within
    \", \"\"\", ' and ''' are ignored."
@@ -492,13 +504,15 @@
     (dotimes (idx (length str))
       (let ((current-char (subseq str idx (1+ idx))))
 	(cond ((string= current-char "(")
-	       (when (or ignore-literals
-			 (not (in-literal-string-p str idx)))
+	       (when (or (not ignore-literals)
+			 (and ignore-literals
+			      (not (in-literal-string-p str idx))))
 		 (decf closed-brackets)
 		 (setf result-idx nil)))
 	      ((string= current-char ")")
-	       (when (or ignore-literals
-			 (not (in-literal-string-p str idx)))
+	       (when (or (not ignore-literals)
+			 (and ignore-literals
+			      (not (in-literal-string-p str idx))))
 		 (incf closed-brackets)
 		 (when (> closed-brackets 0)
 		   (setf result-idx idx)

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Apr  5 05:31:40 2011
@@ -2339,6 +2339,52 @@
 	   r-1))))
 
 
+(test test-all-14
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "SELECT * WHERE {
+                   <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
+                    FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'
+                   #FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
+		   #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
+                   #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
+		   #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
+                 "
+}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+
+
+
+      ;;TODO: use all stored literal datatype information if existent and
+      ;;      cast the values to the actual objects
+      ;;      or
+      ;;      write all string values to the results in a quoted form,
+      ;;      it is also needed to escapte quotes in the actual string value
+      ;;      the filter is called with read-from-string, so a "12" will evaluate
+      ;;      to 12 and "\"abc\"" to "abc
+
+      (map 'list #'(lambda(triple)
+		     (format t "~a - ~a - ~a~%"
+			     (tm-sparql::subject-result triple)
+			     (tm-sparql::predicate-result triple)
+			     (tm-sparql::object-result triple)))
+	   (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
+
+
+
+      (is-true (= (length r-1) 2))
+      (map 'list #'(lambda(item)
+		     (cond
+		       ((string= (getf item :variable) "pred1")
+			nil)
+		       ((string= (getf item :variable) "obj1")
+			nil)))
+	   r-1)
+      (format t "~a~%" r-1))))
+
+
 
 ;TODO: test complex filters
 



From lgiessmann at common-lisp.net  Tue Apr  5 11:23:29 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 05 Apr 2011 07:23:29 -0400
Subject: [isidorus-cvs] r414 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q74M5-0006cv-0i@common-lisp.net>

Author: lgiessmann
Date: Tue Apr  5 07:23:28 2011
New Revision: 414

Log:
changed the behavior of casting string-values to xml-boolean, xml-integer, xml-double and xml-decimal

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Tue Apr  5 07:23:28 2011
@@ -477,6 +477,7 @@
 			  (filter-by-given-object construct :revision revision))
 		      (filter-by-special-uris construct :revision revision))))
 	(map 'list #'(lambda(result)
+		       ;(format t "-->~a<--~%" result) ;TODO: remove
 		       (push (getf result :subject) (subject-result construct))
 		       (push (getf result :predicate) (predicate-result construct))
 		       (push (getf result :object) (object-result construct)))
@@ -1235,35 +1236,88 @@
   (cond ((string= literal-type *xml-string*)
 	 literal-value)
 	((string= literal-type *xml-boolean*)
-	 (when (and (string/= literal-value "false")
-		    (string/= literal-value "true"))
-	   (error (make-condition
-		   'sparql-parser-error
-		   :message (format nil "Could not cast from ~a to ~a"
-				    literal-value literal-type))))
-	 (if (string= literal-value "false")
-	     nil
-	     t))
+	 (cast-literal-to-boolean literal-value))
 	((string= literal-type *xml-integer*)
-	 (handler-case (parse-integer literal-value)
-	   (condition ()
-	     (error (make-condition
-		   'sparql-parser-error
-		   :message (format nil "Could not cast from ~a to ~a"
-				    literal-value literal-type))))))
-	((or (string= literal-type *xml-decimal*) ;;both types are
-	     (string= literal-type *xml-double*)) ;;handled the same way
-	 (let ((value (read-from-string literal-value)))
-	   (unless (numberp value)
-	     (error (make-condition
-		   'sparql-parser-error
-		   :message (format nil "Could not cast from ~a to ~a"
-				    literal-value literal-type))))
-	   value))
+	 (cast-literal-to-integer literal-value))
+	((string= literal-type *xml-double*)
+	 (cast-literal-to-double literal-value))
+	((string= literal-type *xml-decimal*)
+	 (cast-literal-to-decimal literal-value))
 	(t ; return the value as a string
 	 literal-value)))
 
 
+(defun cast-literal-to-decimal (literal-value)
+  "A helper function that casts the passed string value of the literal
+   value to an decimal value."
+  (let ((bad-string
+	 (loop for idx to (1- (length literal-value))
+	    when (and (not (digit-char-p (elt literal-value idx)))
+		      (not (eql (elt literal-value idx) #\.)))
+	    return t)))
+    (when bad-string
+      (error (make-condition
+	      'sparql-parser-error
+	      :message (format nil "Could not cast from ~a to ~a"
+			       literal-value *xml-decimal*)))))
+  ;decimals are handled as single floats
+  (if (find #\. literal-value)
+      (read-from-string literal-value)
+      (read-from-string (concat literal-value ".0"))))
+
+
+(defun cast-literal-to-double (literal-value)
+  "A helper function that casts the passed string value of the literal
+   value to an decimal value."
+  (let ((modified-str ""))
+    (loop for idx to (1- (length literal-value))
+       when (eql (char-downcase (elt literal-value idx)) #\e)
+       do (push-string "d" modified-str)
+       else
+       do (push-string (string (elt literal-value idx)) modified-str))
+    (let ((value
+	   (cond ((or (string= "+INF" modified-str)
+		      (string= "INF" modified-str))
+		  sb-ext:double-float-positive-infinity)
+		 ((string= "-INF" modified-str)
+		  sb-ext:double-float-negative-infinity)
+		 ((find #\d (string-downcase modified-str))
+		  (read-from-string modified-str))
+		 (t
+		  (read-from-string (concat modified-str "d0"))))))
+      (if (typep value 'double-float)
+	  value
+	  (error (make-condition
+		  'sparql-parser-error
+		  :message (format nil "Could not cast from ~a to ~a"
+				   literal-value *xml-double*)))))))
+
+
+(defun cast-literal-to-integer (literal-value)
+  "A helper function that casts the passed string value of the literal
+   value to an integer value."
+  (handler-case (parse-integer literal-value)
+    (condition ()
+      (error (make-condition
+	      'sparql-parser-error
+	      :message (format nil "Could not cast from ~a to ~a"
+			       literal-value *xml-integer*))))))
+  
+
+(defun cast-literal-to-boolean (literal-value)
+  "A helper function that casts the passed string value of the literal
+   value to t or nil."
+  (when (and (string/= literal-value "false")
+	     (string/= literal-value "true"))
+    (error (make-condition
+	    'sparql-parser-error
+	    :message (format nil "Could not cast from ~a to ~a"
+			     literal-value *xml-boolean*))))
+  (if (string= literal-value "false")
+      nil
+      t))
+
+
 (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args)
   (declare (ignorable args))
   (parser-start construct (original-query construct))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Apr  5 07:23:28 2011
@@ -2366,10 +2366,11 @@
       ;;      to 12 and "\"abc\"" to "abc
 
       (map 'list #'(lambda(triple)
-		     (format t "~a - ~a - ~a~%"
+		     (format t "~a - ~a - ~a(~a)~%"
 			     (tm-sparql::subject-result triple)
 			     (tm-sparql::predicate-result triple)
-			     (tm-sparql::object-result triple)))
+			     (tm-sparql::object-result triple)
+			     (tm-sparql::literal-datatype triple)))
 	   (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
 
 



From lgiessmann at common-lisp.net  Tue Apr  5 21:12:57 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 05 Apr 2011 17:12:57 -0400
Subject: [isidorus-cvs] r415 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7DYX-0007hl-3l@common-lisp.net>

Author: lgiessmann
Date: Tue Apr  5 17:12:56 2011
New Revision: 415

Log:
TM-SPARQL: all result values are returned in the correct datatype representation, if there are unsupported datatypes requested the return value is of the form """value"""^^datatype

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Tue Apr  5 17:12:56 2011
@@ -106,7 +106,7 @@
 		     :initform nil
 		     :documentation "Contains the datatype of the literal,
                                      e.g. xml:string"))
-  (:documentation "Represents one element of an RDF-triple."))
+  (:documentation "Represents one element of an RDF-triple.")) 
 
 
 (defclass SPARQL-Triple()
@@ -147,9 +147,14 @@
 	   :documentation "Represents the subject of an RDF-triple.")
    (object-result :initarg :object-result
 		  :accessor object-result
-		  :type T
+		  :type List
 		  :initform nil
-		  :documentation "Contains the result of the object triple elem."))
+		  :documentation "Contains the result of the object triple elem.")
+   (object-datatype :initarg :object-datatype
+		    :accessor object-datatype
+		    :type List
+		    :initform nil
+		    :documentation "Conations the corresponding value's datatype."))
   (:documentation "Represents an entire RDF-triple."))
 
 
@@ -377,9 +382,6 @@
   (:documentation "Processes all filters by calling invoke-filter.")
   (:method ((construct SPARQL-Query))
     (dolist (filter (filters construct))
-
-      (format t ">>>~a<<<~%" filter) ;TODO: remove
-
       (let* ((filter-variable-names
 	      (get-variables-from-filter-string filter))
 	     (filter-variable-values nil)
@@ -453,14 +455,18 @@
 		(push
 		 (list :subject (elt (subject-result triple) idx)
 		       :predicate (elt (predicate-result triple) idx)
-		       :object (elt (object-result triple) idx))
+		       :object (elt (object-result triple) idx)
+		       :object-datatype (elt (object-datatype triple) idx))
 		 new-values)))
 	    (setf (subject-result triple)
 		  (map 'list #'(lambda(elem) (getf elem :subject)) new-values))
 	    (setf (predicate-result triple)
 		  (map 'list #'(lambda(elem) (getf elem :predicate)) new-values))
 	    (setf (object-result triple)
-		  (map 'list #'(lambda(elem) (getf elem :object)) new-values))))))
+		  (map 'list #'(lambda(elem) (getf elem :object)) new-values))
+	    (setf (object-datatype triple)
+		  (map 'list #'(lambda(elem) (getf elem :object-datatype))
+		       new-values))))))
     construct))
 
 
@@ -477,13 +483,11 @@
 			  (filter-by-given-object construct :revision revision))
 		      (filter-by-special-uris construct :revision revision))))
 	(map 'list #'(lambda(result)
-		       ;(format t "-->~a<--~%" result) ;TODO: remove
 		       (push (getf result :subject) (subject-result construct))
 		       (push (getf result :predicate) (predicate-result construct))
-		       (push (getf result :object) (object-result construct)))
-	     ;;literal-datatype is not used and is not returned, since
-	     ;;the values are returned as object of their specific type, e.g.
-	     ;;integer, boolean, string, ...
+		       (push (getf result :object) (object-result construct))
+		       (push (getf result :literal-datatype)
+			     (object-datatype construct)))
 	     results)))))
 
 
@@ -1064,11 +1068,36 @@
 			 (all-variables construct)
 			 (variables construct))))
 	   (cleaned-results (make-result-lists construct)))
-      (map 'list #'(lambda(response-variable)
-		     (list :variable response-variable
-			   :result (variable-intersection response-variable
+      (let ((result
+	     (map 'list #'(lambda(response-variable)
+			    (let ((result
+				   (variable-intersection response-variable
 							  cleaned-results)))
-	   response-variables))))
+			      (list :variable response-variable
+				    :result (getf result :result)
+				    :literal-datatype
+				    (getf result :literal-datatype))))
+		  response-variables)))
+	(cast-result-values result)))))
+
+
+(defun cast-result-values (result-values)
+  "Casts all literal values that are represented as a string to
+   the actual datatype."
+  (declare (List result-values))
+  (loop for set-idx to (1- (length result-values))
+     collect (let ((value-set (getf (elt result-values set-idx) :result))
+		   (type-set (getf (elt result-values set-idx) :literal-datatype))
+		   (var-name (getf (elt result-values set-idx) :variable)))
+	       (list :variable var-name
+		     :result
+		     (loop for value-idx to (1- (length value-set))
+			when (elt type-set value-idx)
+			collect (cast-literal (elt value-set value-idx)
+					      (elt type-set value-idx))
+			else
+			collect (elt value-set value-idx))))))
+
 
 
 (defgeneric make-result-lists (construct)
@@ -1087,6 +1116,7 @@
 			 :result (predicate-result triple)))
 		 (when (variable-p (object triple))
 		   (list :variable (value (object triple))
+			 :literal-datatype (object-datatype triple)
 			 :result (object-result triple)))))))))
 
 
@@ -1130,14 +1160,22 @@
 (defun recursive-intersection (list-1 list-2 more-lists)
   "Returns an intersection of al the passed lists."
   (declare (List list-1 list-2))
-  (let ((current-result
-	 (intersection list-1 list-2
-		       :test #'(lambda(val-1 val-2)
-				 (if (and (stringp val-1) (stringp val-2))
-				     (string= val-1 val-2)
-				     (eql val-1 val-2))))))
+  (let* ((current-result
+	  (intersection (getf list-1 :result) (getf list-2 :result)
+			:test #'(lambda(val-1 val-2)
+				  (if (and (stringp val-1) (stringp val-2))
+				      (string= val-1 val-2)
+				      (eql val-1 val-2)))))
+	 (current-datatypes
+	  (map 'list #'(lambda(result-entry)
+			 (let ((pos (position result-entry (getf list-1 :result)
+					      :test #'string=)))
+			   (when (getf list-1 :literal-datatype)
+			     (elt (getf list-1 :literal-datatype) pos))))
+	       current-result)))
     (if (not more-lists)
-	current-result
+	(list :result current-result
+	      :literal-datatype current-datatypes)
 	(recursive-intersection current-result (first more-lists)
 				(rest more-lists)))))
 
@@ -1157,10 +1195,13 @@
   (:method ((construct SPARQL-Triple) (result-lists List))
     (let* ((triple-variables (variables construct))
 	   (intersections
-	    (map 'list #'(lambda(var)
-			   (list :variable var
-				 :result (variable-intersection
-					  var result-lists)))
+	    (map 'list
+		 #'(lambda(var)
+		     (let ((result (variable-intersection
+				    var result-lists)))
+		       (list :variable var
+			     :result (getf result :result)
+			     :literal-datatype (getf result :literal-datatype))))
 		 triple-variables)))
       (map 'list #'(lambda(entry)
 		     (delete-rows construct (getf entry :variable)
@@ -1197,11 +1238,14 @@
 			    (find (elt var-elem idx) dont-touch-values)))
 		   collect idx))
 	       (new-result-list
-		(map 'list
-		     #'(lambda(row-idx)
-			 (list :subject (elt (subject-result construct) row-idx)
-			       :predicate (elt (predicate-result construct) row-idx)
-			       :object (elt (object-result construct) row-idx)))
+		(map
+		 'list
+		 #'(lambda(row-idx)
+		     (list
+		      :subject (elt (subject-result construct) row-idx)
+		      :predicate (elt (predicate-result construct) row-idx)
+		      :object (elt (object-result construct) row-idx)
+		      :object-datatype (elt (object-datatype construct) row-idx)))
 		     rows-to-hold)))
 	  (setf (subject-result construct)
 		(map 'list #'(lambda(entry)
@@ -1211,7 +1255,10 @@
 			       (getf entry :predicate)) new-result-list))
 	  (setf (object-result construct)
 		(map 'list #'(lambda(entry)
-			       (getf entry :object)) new-result-list)))))))
+			       (getf entry :object)) new-result-list))
+	  (setf (object-datatype construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :object-datatype)) new-result-list)))))))
 
 
 (defgeneric results-for-variable (variable-name result-lists)
@@ -1224,7 +1271,8 @@
 			   result-lists))
 	   (values
 	    (map 'list #'(lambda(entry)
-			   (getf entry :result))
+			   (list :result (getf entry :result)
+				 :literal-datatype (getf entry :literal-datatype)))
 		 cleaned-result-lists)))
       values)))
 
@@ -1244,7 +1292,7 @@
 	((string= literal-type *xml-decimal*)
 	 (cast-literal-to-decimal literal-value))
 	(t ; return the value as a string
-	 literal-value)))
+	 (concat "\"\"\"" literal-value "\"\"\"^^" literal-type))))
 
 
 (defun cast-literal-to-decimal (literal-value)

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Apr  5 17:12:56 2011
@@ -40,7 +40,21 @@
 	   :test-set-compare-operators
 	   :test-set-functions
 	   :test-module-1
-	   :test-module-2))
+	   :test-module-2
+	   :test-all-1
+	   :test-all-2
+	   :test-all-3
+	   :test-all-4
+	   :test-all-5
+	   :test-all-6
+	   :test-all-7
+	   :test-all-8
+	   :test-all-9
+	   :test-all-10
+	   :test-all-11
+	   :test-all-12
+	   :test-all-13
+	   :test-all-14))
 
 
 (in-package :sparql-test)
@@ -219,7 +233,7 @@
     (let ((res (tm-sparql::parse-literal-elem dummy-object query-6)))
       (is (string= (getf res :next-query)
 		   (concat "." (string #\newline))))
-      (is (eql (tm-sparql::value (getf res :value)) 123.4))
+      (is (eql (tm-sparql::value (getf res :value)) 123.4d0))
       (is-false (tm-sparql::literal-lang (getf res :value)))
       (is (string= (tm-sparql::literal-datatype (getf res :value))
 		   *xml-double*))
@@ -2049,12 +2063,12 @@
 			     (getf item :result)
 			     (list "Johann Wolfgang" "von Goethe"
 				   "Johann Wolfgang von Goethe" "Der Zauberlehrling"
-				   "28.08.1749" "22.03.1832" "82" "true" "false"
+				   "28.08.1749" "22.03.1832" 82 t nil
 				   "Hat der alte Hexenmeister
 	sich doch einmal wegbegeben!
 	...
       ")
-			     :test #'string=))
+			     :test #'tm-sparql::literal=))
 			    (t
 			     (is-true (format t "bad variable-name found")))))
 	   r-1))))
@@ -2346,31 +2360,22 @@
     (let* ((q-1 (concat
 		 "SELECT * WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
-                    FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'
-                   #FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
-		   #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
-                   #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
-		   #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
+                    FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
+                   FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
+		   FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
+                   FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
+		   FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
                  "
 }"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
 
 
-
-      ;;TODO: use all stored literal datatype information if existent and
-      ;;      cast the values to the actual objects
-      ;;      or
-      ;;      write all string values to the results in a quoted form,
-      ;;      it is also needed to escapte quotes in the actual string value
-      ;;      the filter is called with read-from-string, so a "12" will evaluate
-      ;;      to 12 and "\"abc\"" to "abc
-
       (map 'list #'(lambda(triple)
-		     (format t "~a - ~a - ~a(~a)~%"
+		     (format t "~a - ~a - ~a[~a]~%"
 			     (tm-sparql::subject-result triple)
 			     (tm-sparql::predicate-result triple)
 			     (tm-sparql::object-result triple)
-			     (tm-sparql::literal-datatype triple)))
+			     (tm-sparql::object-datatype triple)))
 	   (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
 
 
@@ -2388,6 +2393,8 @@
 
 
 ;TODO: test complex filters
+;TODO: check if object results are in the actual object-represenrtation and not as string
+;TODO: rename test-all-? test-module-?
 
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Tue Apr  5 21:36:42 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 05 Apr 2011 17:36:42 -0400
Subject: [isidorus-cvs] r416 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7DvW-0001Bh-JX@common-lisp.net>

Author: lgiessmann
Date: Tue Apr  5 17:36:42 2011
New Revision: 416

Log:
TM-SPARQL: fixed a bug in recursive-intersection

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Tue Apr  5 17:36:42 2011
@@ -1176,7 +1176,9 @@
     (if (not more-lists)
 	(list :result current-result
 	      :literal-datatype current-datatypes)
-	(recursive-intersection current-result (first more-lists)
+	(recursive-intersection (list :result current-result
+				      :literal-datatype current-datatypes)
+				(first more-lists)
 				(rest more-lists)))))
 
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Apr  5 17:36:42 2011
@@ -2391,7 +2391,7 @@
       (format t "~a~%" r-1))))
 
 
-
+;TODO: cast literal-values when called in filters
 ;TODO: test complex filters
 ;TODO: check if object results are in the actual object-represenrtation and not as string
 ;TODO: rename test-all-? test-module-?



From lgiessmann at common-lisp.net  Wed Apr  6 09:26:02 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 06 Apr 2011 05:26:02 -0400
Subject: [isidorus-cvs] r417 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1Q7Ozy-0001cH-Fh@common-lisp.net>

Author: lgiessmann
Date: Wed Apr  6 05:26:02 2011
New Revision: 417

Log:
TM-SPARQL: adopted all unit-tests to the latest changes; fixed some bug that handles unsupported datatypes

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_parser.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Wed Apr  6 05:26:02 2011
@@ -589,7 +589,7 @@
 			(list :subject subj-uri
 			      :predicate pred-uri
 			      :object (charvalue char)
-			      :literal-datatype literal-datatype))))
+			      :literal-datatype literal-datatype))))	  
 	  (remove-if #'(lambda(char)
 			 (typep char 'VariantC))
 		     (return-characteristics literal-value literal-datatype)))))
@@ -909,8 +909,10 @@
 	     (string/= literal-datatype *xml-boolean*))
 	construct
 	(handler-case
-	    (let ((occ-value (cast-literal (charvalue construct)
-					   (datatype construct))))
+	    (let ((occ-value
+		   (cast-literal (charvalue construct)
+				 (datatype construct)
+				 :back-as-string-when-unsupported t)))
 	      (when (literal= occ-value literal-value)
 		construct))
 	  (condition () nil)))))	      
@@ -1279,10 +1281,12 @@
       values)))
 
 
-(defun cast-literal (literal-value literal-type)
+(defun cast-literal (literal-value literal-type
+		     &key (back-as-string-when-unsupported nil))
   "A helper function that casts the passed string value of the literal
    corresponding to the passed literal-type."
-  (declare (String literal-value literal-type))
+  (declare (String literal-value literal-type)
+	   (Boolean back-as-string-when-unsupported))
   (cond ((string= literal-type *xml-string*)
 	 literal-value)
 	((string= literal-type *xml-boolean*)
@@ -1294,7 +1298,9 @@
 	((string= literal-type *xml-decimal*)
 	 (cast-literal-to-decimal literal-value))
 	(t ; return the value as a string
-	 (concat "\"\"\"" literal-value "\"\"\"^^" literal-type))))
+	 (if back-as-string-when-unsupported
+	     literal-value
+	     (concat "\"\"\"" literal-value "\"\"\"^^" literal-type)))))
 
 
 (defun cast-literal-to-decimal (literal-value)

Modified: trunk/src/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_parser.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_parser.lisp	Wed Apr  6 05:26:02 2011
@@ -230,7 +230,8 @@
 	   (l-lang (getf result-2 :lang))
 	   (next-query (getf result-2 :next-query)))
       (list :next-query next-query :lang l-lang :type l-type
-	    :value (cast-literal l-value l-type)))))
+	    :value (cast-literal l-value l-type
+				 :back-as-string-when-unsupported t)))))
 
 
 (defgeneric separate-literal-lang-or-type (construct query-string)

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Wed Apr  6 05:26:02 2011
@@ -195,12 +195,15 @@
       (let ((search-idx (search-first (list string-to-replace) main-string)))
 	(if (not search-idx)
 	    main-string
-	    (let ((modified-string
-		   (concat (subseq main-string 0 search-idx)
-			   new-string
-			   (subseq main-string
-				   (+ search-idx (length string-to-replace))))))
-	      (string-replace modified-string string-to-replace new-string))))))
+	    (let* ((leading-part (subseq main-string 0 search-idx))
+		   (trailing-part
+		    (subseq main-string
+			    (+ search-idx (length string-to-replace))))
+		   (modified-string
+		    (concat leading-part new-string trailing-part)))
+	      (if (search-first (list string-to-replace) trailing-part)
+		  (string-replace modified-string string-to-replace new-string)
+		  modified-string))))))
 
 
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Apr  6 05:26:02 2011
@@ -41,20 +41,20 @@
 	   :test-set-functions
 	   :test-module-1
 	   :test-module-2
-	   :test-all-1
-	   :test-all-2
-	   :test-all-3
-	   :test-all-4
-	   :test-all-5
-	   :test-all-6
-	   :test-all-7
-	   :test-all-8
-	   :test-all-9
-	   :test-all-10
-	   :test-all-11
-	   :test-all-12
-	   :test-all-13
-	   :test-all-14))
+	   :test-module-3
+	   :test-module-4
+	   :test-module-5
+	   :test-module-6
+	   :test-module-7
+	   :test-module-8
+	   :test-module-9
+	   :test-module-10
+	   :test-module-11
+	   :test-module-12
+	   :test-module-13
+	   :test-module-14
+	   :test-module-15
+	   :test-module-16))
 
 
 (in-package :sparql-test)
@@ -1603,7 +1603,7 @@
 	      (is-false (set-exclusive-or
 			 (getf (second result-2) :result)
 			 (list "Johann Wolfgang" "von Goethe"
-			       "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")
+			       (concat "\"\"\"http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe\"\"\"^^" *xml-uri*))
 			 :test #'string=)))
 	    (progn 
 	      (is (= (length (getf (second result-2) :result)) 0))
@@ -1612,7 +1612,7 @@
 	      (is-false (set-exclusive-or
 			 (getf (first result-2) :result)
 			 (list "Johann Wolfgang" "von Goethe"
-			       "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")
+			       (concat "\"\"\"http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe\"\"\"^^" *xml-uri*))
 			 :test #'string=))))))))
 
 
@@ -1642,7 +1642,7 @@
 		   :test #'string=))))))
 
 
-(test test-all-1
+(test test-module-3
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1698,7 +1698,7 @@
     (is-true (d:get-item-by-psi *rdf-type* :revision 0))))
 
 
-(test test-all-2
+(test test-module-4
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1724,7 +1724,7 @@
 	   r-1))))
 
 
-(test test-all-3
+(test test-module-5
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1752,7 +1752,7 @@
 	   r-1))))
 
 
-(test test-all-4
+(test test-module-6
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1802,7 +1802,7 @@
 	   r-1))))
 
 
-(test test-all-5
+(test test-module-7
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1831,7 +1831,7 @@
 	   r-1))))
 
 
-(test test-all-6
+(test test-module-8
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1874,7 +1874,7 @@
 	   r-1))))
 
 
-(test test-all-7
+(test test-module-9
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1898,7 +1898,7 @@
 	   r-1))))
 
 
-(test test-all-8
+(test test-module-10
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1921,7 +1921,8 @@
 					 "Johann Wolfgang von Goethe")))
 			   ((string= (getf item :variable) "obj2")
 			    (is (string= (first (getf item :result))
-					 "28.08.1749")))
+					 (concat "\"\"\"28.08.1749\"\"\"^^"
+						 *xml-date*))))
 			   ((string= (getf item :variable) "obj3")
 			    (is (string= (first (getf item :result))
 					 "Goethe")))
@@ -1942,7 +1943,7 @@
 	   r-1))))
 
 
-(test test-all-9
+(test test-module-11
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -1961,7 +1962,7 @@
       (is-false r-1))))
 
 
-(test test-all-10
+(test test-module-12
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -2074,7 +2075,7 @@
 	   r-1))))
 
 
-(test test-all-11
+(test test-module-13
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -2127,24 +2128,27 @@
 			   ((string= (getf item :variable) "obj1")
 			    (is (= (length (getf item :result)) 17))
 			    (is-true (find "Johann Wolfgang" (getf item :result)
-					   :test #'string=))
+					   :test #'tm-sparql::literal=))
 			    (is-true (find "von Goethe" (getf item :result)
-					   :test #'string=))
-			    (is-true (find "true" (getf item :result)
-					   :test #'string=))
-			    (is-true (find "false" (getf item :result)
-					   :test #'string=))
-			    (is-true (find "28.08.1749" (getf item :result)
-					   :test #'string=))
-			    (is-true (find "22.03.1832" (getf item :result)
-					   :test #'string=))
-			    (is-true (find "82" (getf item :result)
-					   :test #'string=))
+					   :test #'tm-sparql::literal=))
+			    (is-true (find t (getf item :result)
+					   :test #'tm-sparql::literal=))
+			    (is-true (position nil (getf item :result)
+					       :test #'tm-sparql::literal=))
+			    (is-true (find (concat "'28.08.1749'^^" *xml-date*)
+					   (getf item :result)
+					   :test #'tm-sparql::literal=))
+			    (is-true (find (concat "'22.03.1832'^^" *xml-date*)
+					   (getf item :result)
+					   :test #'tm-sparql::literal=))
+			    (is-true (find 82 (getf item :result)
+					   :test #'tm-sparql::literal=))
 			    (is-true (find "<http://some.where/tmsparql/author>"
-					   (getf item :result) :test #'string=))
+					   (getf item :result)
+					   :test #'tm-sparql::literal=))
 			    (is-true
 			     (find "<http://some.where/psis/poem/zauberlehrling>"
-				   (getf item :result) :test #'string=)))
+				   (getf item :result) :test #'tm-sparql::literal=)))
 			   ((string= (getf item :variable) "obj2")
 			    (is (= (length (getf item :result)) 3))
 			    (is-false
@@ -2182,9 +2186,9 @@
 			    (is-false
 			     (set-exclusive-or
 			      (getf item :result)
-			      (list "28.08.1749"
+			      (list (concat "'28.08.1749'^^" *xml-date*)
 				    "<http://some.where/ii/goethe-occ-reifier>")
-			      :test #'string=)))
+			      :test #'tm-sparql::literal=)))
 			   ((string= (getf item :variable) "obj6")
 			   (is (= (length (getf item :result)) 2))
 			    (is-false
@@ -2198,7 +2202,7 @@
 	   r-1))))
 
 
-(test test-all-12
+(test test-module-14
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -2312,7 +2316,7 @@
 
 
 
-(test test-all-13
+(test test-module-15
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
@@ -2353,14 +2357,14 @@
 	   r-1))))
 
 
-(test test-all-14
+(test test-module-16
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
     (let* ((q-1 (concat
 		 "SELECT * WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
-                    FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
+                   FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
                    FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
 		   FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
                    FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
@@ -2393,8 +2397,6 @@
 
 ;TODO: cast literal-values when called in filters
 ;TODO: test complex filters
-;TODO: check if object results are in the actual object-represenrtation and not as string
-;TODO: rename test-all-? test-module-?
 
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Wed Apr  6 11:01:58 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 06 Apr 2011 07:01:58 -0400
Subject: [isidorus-cvs] r418 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7QUo-0000FE-7r@common-lisp.net>

Author: lgiessmann
Date: Wed Apr  6 07:01:57 2011
New Revision: 418

Log:
TM-SPARQL: filters use now the actual datatype, e.g. 82 instead of '82' ...

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Wed Apr  6 07:01:57 2011
@@ -297,6 +297,28 @@
       (push variable-name (variables construct)))))
 
 
+
+(defgeneric cast-variable-values(construct variable-value-list)
+  (:documentation "Casts all values contained in the variable value list
+                   to the corresponding type that is also stored in the
+                   variable-value list.")
+  (:method ((construct SPARQL-Query) (variable-value-list List))
+    (map 'list
+	 #'(lambda(item)
+	     (map 'list
+		  #'(lambda(inner-item)
+		      (list :variable-name (getf inner-item :variable-name)
+			    :variable-value
+			    (if (and (getf inner-item :variable-value)
+				     (getf inner-item :literal-datatype))
+				(cast-literal (getf inner-item :variable-value)
+					      (getf inner-item :literal-datatype)
+					      :back-as-string-when-unsupported t)
+				(getf inner-item :variable-value))))
+		  item))
+	 variable-value-list)))
+
+
 (defgeneric make-variable-values(construct variable-name existing-results)
   (:documentation "Returns a list of values that are bound to the passed
                    variable. The first occurrence of the given variable
@@ -310,29 +332,40 @@
 	       when (and (variable-p (subject triple))
 			 (string= (value (subject triple)) variable-name))
 	       return (progn (setf found-p t)
-			     (subject-result triple))
+			     (list :result (subject-result triple)))
 	       when (and (variable-p (predicate triple))
 			 (string= (value (predicate triple)) variable-name))
 	       return (progn (setf found-p t)
-			     (predicate-result triple))
+			     (list :result (predicate-result triple)))
 	       when (and (variable-p (object triple))
 			 (string= (value (object triple))
 				  variable-name))
 	       return (progn (setf found-p t)
-			     (object-result triple))))
+			     (list :result (object-result triple)
+				   :literal-datatype (object-datatype triple)))))
 	   (new-results nil))
       (if (not found-p)
 	  existing-results
 	  (if existing-results
-	      (dolist (result results new-results)
+	      (dotimes (idx (length (getf results :result)) new-results)
 		(dolist (old-result existing-results)
-		  (push (append old-result (list (list :variable-name variable-name
-						       :variable-value result)))
+		  (push (append old-result
+				(list
+				 (list :variable-name variable-name
+				       :literal-datatype
+				       (when (getf results :literal-datatype)
+					 (elt (getf results :literal-datatype) idx))
+				       :variable-value
+				       (elt (getf results :result) idx))))
 			new-results)))
-	      (map 'list #'(lambda(result)
-			     (list (list :variable-name variable-name
-					 :variable-value result)))
-		   results))))))
+	      (loop for idx to (1- (length (getf results :result)))
+		 collect (list
+			  (list :variable-name variable-name
+				:literal-datatype
+				(when (getf results :literal-datatype)
+				  (elt (getf results :literal-datatype) idx))
+				:variable-value
+				(elt (getf results :result) idx)))))))))
 
 
 (defun to-lisp-code (variable-values filter)
@@ -389,16 +422,24 @@
 	(dolist (var-name filter-variable-names)
 	  (setf filter-variable-values
 		(make-variable-values construct var-name filter-variable-values)))
+	(setf filter-variable-values
+	      (cast-variable-values construct filter-variable-values))
 	(dolist (filter (filters construct))
 	  (dolist (var-elem filter-variable-values)
+
+	    ;(format t "~a~%==>~a~%~%" (to-lisp-code var-elem filter)
+	    ;(eval (read-from-string (to-lisp-code var-elem filter)))) ;TODO: remove
+
 	    (when (eval (read-from-string (to-lisp-code var-elem filter)))
 	      (map 'list #'(lambda(list-elem)
 			     (push list-elem true-values))
 		   var-elem))))
+	;(format t "tv: -->~a<--~%" true-values) ;TODO: remove
 	(let ((values-to-remove
 	       (return-false-values filter-variable-values
 				    (remove-duplicates true-values
 						       :test #'variable-list=))))
+	  ;(format t "vr: -->~a<--~%" values-to-remove) ;TODO: remove
 	  (dolist (to-del values-to-remove)
 	    (delete-rows-by-value construct (getf to-del :variable-name)
 				  (getf to-del :variable-value))))))
@@ -415,8 +456,18 @@
 	  (local-results
 	   (cond ((eql what :subject) (subject-result construct))
 		 ((eql what :predicate) (predicate-result construct))
-		 ((eql what :object) (object-result construct))))
-	  (is-variable
+		 ((eql what :object)
+		  (if (object-datatype construct)
+		      (loop for idx to (1- (length (object-result construct)))
+			 when (elt (object-datatype construct) idx)
+			 collect (cast-literal
+				  (elt (object-result construct) idx)
+				  (elt (object-datatype construct) idx)
+				  :back-as-string-when-unsupported t)
+			 else
+			 collect (elt (object-result construct) idx))
+		      (object-result construct)))))
+	  (variable-p
 	   (cond ((eql what :subject)
 		  (and (variable-p (subject construct))
 		       (value (subject construct))))
@@ -426,7 +477,7 @@
 		 ((eql what :object)
 		  (and (variable-p (object construct))
 		       (value (object construct)))))))
-      (when is-variable
+      (when variable-p
 	(remove-null
 	 (dotimes (idx (length local-results))
 	   (when (literal= variable-value (elt local-results idx))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Apr  6 07:01:57 2011
@@ -2365,22 +2365,22 @@
 		 "SELECT * WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
                    FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
-                   FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
-		   FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
-                   FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
-		   FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
-                 "
+                   #FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'^^" *xml-integer* "
+		   #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
+                   #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
+		   #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
+		 "
 }"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
 
 
-      (map 'list #'(lambda(triple)
-		     (format t "~a - ~a - ~a[~a]~%"
-			     (tm-sparql::subject-result triple)
-			     (tm-sparql::predicate-result triple)
-			     (tm-sparql::object-result triple)
-			     (tm-sparql::object-datatype triple)))
-	   (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
+      ;(map 'list #'(lambda(triple)
+      ;(format t "~a - ~a - ~a[~a]~%"
+      ;(tm-sparql::subject-result triple)
+      ;(tm-sparql::predicate-result triple)
+      ;(tm-sparql::object-result triple)
+      ;(tm-sparql::object-datatype triple)))
+      ;(tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
 
 
 



From lgiessmann at common-lisp.net  Wed Apr  6 15:02:36 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 06 Apr 2011 11:02:36 -0400
Subject: [isidorus-cvs] r419 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1Q7UFg-0003A2-DX@common-lisp.net>

Author: lgiessmann
Date: Wed Apr  6 11:02:36 2011
New Revision: 419

Log:
TM-SPARQL: sparql filters now support constants of the form 'string-value'^^datatype and 'string'@lang

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Wed Apr  6 11:02:36 2011
@@ -177,7 +177,7 @@
     (cond (type-suffix type-suffix)
 	  ((integerp x) constants::*xml-integer*)
 	  ((floatp x) constants::*xml-decimal*)
-	  ((numberp x) constants::*xml-double*)
+	  ((typep x 'double-float) constants::*xml-double*)
 	  ((stringp x) constants::*xml-string*)
 	  (t (type-of x)))))
 

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Wed Apr  6 11:02:36 2011
@@ -426,20 +426,17 @@
 	      (cast-variable-values construct filter-variable-values))
 	(dolist (filter (filters construct))
 	  (dolist (var-elem filter-variable-values)
-
-	    ;(format t "~a~%==>~a~%~%" (to-lisp-code var-elem filter)
-	    ;(eval (read-from-string (to-lisp-code var-elem filter)))) ;TODO: remove
+	    
+	    ;(format t "~%~%>>~a<<~%~%" (to-lisp-code var-elem filter)); TODO: remove
 
 	    (when (eval (read-from-string (to-lisp-code var-elem filter)))
 	      (map 'list #'(lambda(list-elem)
 			     (push list-elem true-values))
 		   var-elem))))
-	;(format t "tv: -->~a<--~%" true-values) ;TODO: remove
 	(let ((values-to-remove
 	       (return-false-values filter-variable-values
 				    (remove-duplicates true-values
 						       :test #'variable-list=))))
-	  ;(format t "vr: -->~a<--~%" values-to-remove) ;TODO: remove
 	  (dolist (to-del values-to-remove)
 	    (delete-rows-by-value construct (getf to-del :variable-name)
 				  (getf to-del :variable-value))))))

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Wed Apr  6 11:02:36 2011
@@ -106,8 +106,10 @@
 	   (original-filter-string
 	    (subseq query-string 0 (- (length query-string)
 				      (length next-query))))
+	   (filter-string-casted-constants
+	    (cast-literal-constants construct filter-string))
 	   (filter-string-unary-ops
-	    (set-unary-operators construct filter-string))
+	    (set-unary-operators construct filter-string-casted-constants))
 	   (filter-string-or-and-ops
 	    (set-or-and-operators construct filter-string-unary-ops
 				  original-filter-string))
@@ -119,10 +121,57 @@
 	    (set-functions construct filter-string-compare-ops)))
       (add-filter construct
 		  (scan-filter-for-deprecated-calls
-		   construct filter-string-functions original-filter-string))
+		   construct filter-string-functions filter-string))
       (parse-group construct next-query))))
 
 
+(defgeneric cast-literal-constants (construct filter-string)
+  (:documentation "Casts all constants of the form 'string-value'^^datatype to an
+                   object of the specified type. If the specified type is not
+                   supported the return value is the string-value without a
+                   type specifier.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((first-pos (search-first (list "'" "\"") filter-string)))
+      (if (not first-pos)
+	  filter-string
+	  (let* ((delimiters
+		  (append (white-space) *supported-brackets* (list "}")))
+		 (result (get-literal (subseq filter-string first-pos)))
+		 (literal-value (getf result :literal))
+		 (next-string (getf result :next-string))
+		 (lang
+		  (when (string-starts-with next-string "@")
+		    (let ((end-pos (search-first delimiters next-string)))
+		      (when end-pos
+			(subseq next-string 0 end-pos)))))
+		 (type
+		  (when (string-starts-with next-string "^^")
+		    (let ((end-pos
+			   (let ((pos (search-first delimiters next-string)))
+			     (if pos
+				 pos
+				 (length next-string)))))
+		      (when end-pos
+			(subseq next-string 2 end-pos)))))
+		 (modified-literal-value
+		  (if type
+		      (if (> (length literal-value) 0)
+			  (string-trim (list (elt literal-value 0)) literal-value)
+			  literal-value)
+		      literal-value)))
+	    (concat (subseq filter-string 0 first-pos)
+		    (if type
+			(write-to-string
+			 (cast-literal modified-literal-value type
+				       :back-as-string-when-unsupported t))
+			modified-literal-value)
+		    (cast-literal-constants
+		     construct
+		     (subseq next-string (cond (lang (length lang))
+					       (type (+ 2 (length type)))
+					       (t 0))))))))))
+
+
 (defgeneric scan-filter-for-deprecated-calls (construct filter-string
 							original-filter)
   (:documentation "Returns the passed filter-string where all functions
@@ -695,7 +744,7 @@
   (declare (String filter-string)
 	   (Integer idx))
   (let* ((string-after (subseq filter-string (1+ idx)))
-	 (cleaned-str (cut-comment string-after)))
+	 (cleaned-str (trim-whitespace-left string-after)))
     (cond ((string-starts-with cleaned-str "(")
 	   (let ((result (bracket-scope cleaned-str)))
 	     (list :next-query (string-after cleaned-str result)
@@ -741,14 +790,14 @@
    that is the scope of the function, i.e. the function name and all its
    variable including the closing )."
   (declare (String str))
-  (let* ((cleaned-str (cut-comment str))
+  (let* ((cleaned-str (trim-whitespace-left str))
 	 (after-fun
 	  (remove-null (map 'list #'(lambda(fun)
 				      (when (string-starts-with cleaned-str fun)
 					(string-after str fun)))
 			    *supported-functions*)))
 	 (fun-suffix (when after-fun
-		       (cut-comment (first after-fun)))))
+		       (trim-whitespace-left (first after-fun)))))
     (when fun-suffix
       (let* ((args (bracket-scope fun-suffix))
 	     (fun-name (string-until cleaned-str args)))
@@ -864,11 +913,6 @@
 		   (setf idx (- (1- (length query-string))
 				(length (getf result :next-string))))
 		   (push-string (getf result :literal) filter-string)))
-		((string= "#" current-char)
-		 (let ((comment-string
-			(string-until (subseq query-string idx)
-				      (string #\newline))))
-		   (setf idx (+ idx (length comment-string)))))
 		((and (string= current-char (string #\newline))
 		      (= 0 open-brackets))
 		 (setf result

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Wed Apr  6 11:02:36 2011
@@ -280,7 +280,7 @@
   "Returns the end of the literal corresponding to the passed delimiter
    string. The query-string must start after the opening literal delimiter.
    The return value is an int that represents the start index of closing
-   delimiter. delimiter must be either \", ', or '''.
+   delimiter. delimiter must be either \", ', \"\"\", or '''.
    If the returns value is nil, there is no closing delimiter."
   (declare (String query-string delimiter)
 	   (Integer overall-pos))
@@ -297,7 +297,7 @@
 (defun get-literal-quotation (str)
   "Returns ', ''', \" or \"\"\" when the string starts with a literal delimiter."
   (cond ((string-starts-with str "'''")
-	 "'")
+	 "'''")
 	((string-starts-with str "\"\"\"")
 	 "\"\"\"")
 	((string-starts-with str "'")

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Apr  6 11:02:36 2011
@@ -1546,9 +1546,9 @@
     (with-revision 0
       (let* ((query-1
 	      "BASE <http://some.where/psis/poem/>
-              SELECT $subject ?predicate WHERE{
-               ?subject $predicate <zauberlehrling> .
-               FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}")
+               SELECT $subject ?predicate WHERE{
+                ?subject $predicate <zauberlehrling> .
+                FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}")
 	     (query-2 "SELECT ?object ?subject WHERE{
                         <http://some.where/psis/author/goethe> ?predicate ?object .
                         FILTER (isLITERAL(?object) &&
@@ -2364,8 +2364,8 @@
     (let* ((q-1 (concat
 		 "SELECT * WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
-                   FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
-                   #FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'^^" *xml-integer* "
+                   #FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
+                   FILTER ?obj1 = 'von Goethe'^^" *xml-string* " || ?obj1 = '82'^^" *xml-integer* "
 		   #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
                    #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
 		   #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
@@ -2373,17 +2373,6 @@
 }"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
 
-
-      ;(map 'list #'(lambda(triple)
-      ;(format t "~a - ~a - ~a[~a]~%"
-      ;(tm-sparql::subject-result triple)
-      ;(tm-sparql::predicate-result triple)
-      ;(tm-sparql::object-result triple)
-      ;(tm-sparql::object-datatype triple)))
-      ;(tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))
-
-
-
       (is-true (= (length r-1) 2))
       (map 'list #'(lambda(item)
 		     (cond
@@ -2395,7 +2384,6 @@
       (format t "~a~%" r-1))))
 
 
-;TODO: cast literal-values when called in filters
 ;TODO: test complex filters
 
 (defun run-sparql-tests ()



From lgiessmann at common-lisp.net  Wed Apr  6 15:14:34 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 06 Apr 2011 11:14:34 -0400
Subject: [isidorus-cvs] r420 - trunk/src/unit_tests
Message-ID: <E1Q7URG-0003FQ-NL@common-lisp.net>

Author: lgiessmann
Date: Wed Apr  6 11:14:34 2011
New Revision: 420

Log:
TM-SPARQL: fixed the unit-tests test-module-14, test-module-15, and test-module-16

Modified:
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Apr  6 11:14:34 2011
@@ -2229,7 +2229,7 @@
 				    "<http://some.where/tmsparql/writer>"
 				    (concat "<" *tms-player* ">"))
 			      (getf item :result) :test #'string=)))
-			   ((string= (getf item :variable) "obj1")
+			   ((string= (getf item :variable) "subj1")
 			    (is (= (length (getf item :result)) 4))
 			    (is-false
 			     (set-exclusive-or
@@ -2258,7 +2258,7 @@
 				 (string= (getf item :variable) "pred5"))
 			     (is-false (getf item :result)))
 			    ((or (string= (getf item :variable) "subj2")
-				 (string= (getf item :variable) "obj5"))
+				 (string= (getf item :variable) "subj5"))
 			     (is-false (getf item :result)))
 			    ((or (string= (getf item :variable) "pred3")
 				 (string= (getf item :variable) "pred4"))
@@ -2266,7 +2266,7 @@
 			     (is (string= (first (getf item :result))
 					  (concat "<" *tms-topicProperty* ">"))))
 			    ((or (string= (getf item :variable) "subj3")
-				 (string= (getf item :variable) "obj4"))
+				 (string= (getf item :variable) "subj4"))
 			     (is (= (length (getf item :result)) 1))
 			     (is (string= (first (getf item :result))
 					  "<http://some.where/tmsparql/author/goethe>")))
@@ -2311,11 +2311,13 @@
 					 (get-item-by-item-identifier
 					  "http://some.where/ii/role-reifier"
 					  :revision 0) :revision 0))))))
-			      (getf item :result) :test #'string=))))
+			      (getf item :result) :test #'string=))
+			    (t
+			     (is-true (format t "bad variable-name found ~a"
+					      (getf item :variable))))))
 	   r-1))))
 
 
-
 (test test-module-15
   "Tests the entire module with the file sparql_test.xtm"
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
@@ -2353,7 +2355,10 @@
 				      (uri (first (psis (player role :revision 0)
 							:revision 0)))
 				      "http://some.where/tmsparql/author/goethe")
-				return role)))))))))
+				return role)))))))
+		       (t
+			(is-true (format t "bad variable-name found ~a"
+					 (getf item :variable))))))
 	   r-1))))
 
 
@@ -2364,24 +2369,35 @@
     (let* ((q-1 (concat
 		 "SELECT * WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
-                   #FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
-                   FILTER ?obj1 = 'von Goethe'^^" *xml-string* " || ?obj1 = '82'^^" *xml-integer* "
-		   #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1)
-                   #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
-		   #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
-		 "
-}"))
+                   FILTER ?obj1 = 'von Goethe' || ?obj1 = 82
+                   FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'^^" *xml-integer* "
+		   FILTER (?obj1 = 'von Goethe'^^" *xml-string* " || 82 = ?obj1)
+                   FILTER (?obj1 = 'von Goethe') || (82 = ?obj1)
+		   FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))"
+		 "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
-
       (is-true (= (length r-1) 2))
       (map 'list #'(lambda(item)
 		     (cond
 		       ((string= (getf item :variable) "pred1")
-			nil)
+			(is (= (length (getf item :result)) 2))
+			(is (find "<http://some.where/tmsparql/last-name>"
+				  (getf item :result) :test #'string=))
+			(is (find "<http://some.where/tmsparql/years>"
+				  (getf item :result) :test #'string=)))
 		       ((string= (getf item :variable) "obj1")
-			nil)))
-	   r-1)
-      (format t "~a~%" r-1))))
+			(is (= (length (getf item :result)) 2))
+			(is (find 82 (getf item :result) :test #'tm-sparql::literal=))
+			(is (find "von Goethe" (getf item :result)
+				  :test #'tm-sparql::literal=)))
+		       (t
+			(is-true (format t "bad variable-name found ~a"
+					 (getf item :variable))))))
+			
+	   r-1))))
+
+
+
 
 
 ;TODO: test complex filters



From lgiessmann at common-lisp.net  Wed Apr  6 16:14:13 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 06 Apr 2011 12:14:13 -0400
Subject: [isidorus-cvs] r421 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7VMz-00089C-Du@common-lisp.net>

Author: lgiessmann
Date: Wed Apr  6 12:14:13 2011
New Revision: 421

Log:
TM-SPARQL: fixed an bug that influences the efficiency of the system, i.e. when there are more than one filter the system is getting slow

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Wed Apr  6 12:14:13 2011
@@ -417,29 +417,26 @@
     (dolist (filter (filters construct))
       (let* ((filter-variable-names
 	      (get-variables-from-filter-string filter))
-	     (filter-variable-values nil)
-	     (true-values nil))
+	     (filter-variable-values nil))
 	(dolist (var-name filter-variable-names)
 	  (setf filter-variable-values
 		(make-variable-values construct var-name filter-variable-values)))
 	(setf filter-variable-values
 	      (cast-variable-values construct filter-variable-values))
 	(dolist (filter (filters construct))
-	  (dolist (var-elem filter-variable-values)
-	    
-	    ;(format t "~%~%>>~a<<~%~%" (to-lisp-code var-elem filter)); TODO: remove
-
-	    (when (eval (read-from-string (to-lisp-code var-elem filter)))
-	      (map 'list #'(lambda(list-elem)
-			     (push list-elem true-values))
-		   var-elem))))
-	(let ((values-to-remove
-	       (return-false-values filter-variable-values
-				    (remove-duplicates true-values
-						       :test #'variable-list=))))
-	  (dolist (to-del values-to-remove)
-	    (delete-rows-by-value construct (getf to-del :variable-name)
-				  (getf to-del :variable-value))))))
+	  (let ((true-values nil))
+	    (dolist (var-elem filter-variable-values)
+	      (when (eval (read-from-string (to-lisp-code var-elem filter)))
+		(map 'list #'(lambda(list-elem)
+			       (push list-elem true-values))
+		     var-elem)))
+	    (let ((values-to-remove
+		   (return-false-values filter-variable-values
+					(remove-duplicates true-values
+							   :test #'variable-list=))))
+	      (dolist (to-del values-to-remove)
+		(delete-rows-by-value construct (getf to-del :variable-name)
+				      (getf to-del :variable-value))))))))
     construct))
 
 

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Wed Apr  6 12:14:13 2011
@@ -39,7 +39,7 @@
 
 
 (defparameter *allowed-filter-calls*
-  (append (list "one+" "one-" "progn" "or" "and" "not" "/=" "="
+  (append (list "one+" "one-" "progn" "or" "and" "not" "!=" "="
 		">" ">=" "<" "<=" "+" "-" "*" "/")
 	  *supported-functions*))
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Apr  6 12:14:13 2011
@@ -54,7 +54,8 @@
 	   :test-module-13
 	   :test-module-14
 	   :test-module-15
-	   :test-module-16))
+	   :test-module-16
+	   :test-module-17))
 
 
 (in-package :sparql-test)
@@ -2397,10 +2398,21 @@
 	   r-1))))
 
 
+(test test-module-17
+  "Tests the entire module with the file sparql_test.xtm"
+  (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
+    (tm-sparql:init-tm-sparql)
+    (let* ((q-1 (concat
+		 "SELECT * WHERE {
+                   <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
+                   FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82
+                   FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1"
+		 "}"))
+	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
+      ;(is-true (= (length r-1) 2))
+      (format t "~a~%" r-1))))
 
 
 
-;TODO: test complex filters
-
 (defun run-sparql-tests ()
   (it.bese.fiveam:run! 'sparql-test:sparql-tests))



From lgiessmann at common-lisp.net  Wed Apr  6 20:53:10 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Wed, 06 Apr 2011 16:53:10 -0400
Subject: [isidorus-cvs] r422 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7Ziw-0002Ui-On@common-lisp.net>

Author: lgiessmann
Date: Wed Apr  6 16:53:10 2011
New Revision: 422

Log:
TM-SPARQL: fixed a bug when there is a greater amount of variables in filters contained in one select-group

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Wed Apr  6 16:53:10 2011
@@ -413,7 +413,7 @@
 
 (defgeneric process-filters (construct)
   (:documentation "Processes all filters by calling invoke-filter.")
-  (:method ((construct SPARQL-Query))
+  (:method ((construct SPARQL-Query))      
     (dolist (filter (filters construct))
       (let* ((filter-variable-names
 	      (get-variables-from-filter-string filter))
@@ -423,20 +423,19 @@
 		(make-variable-values construct var-name filter-variable-values)))
 	(setf filter-variable-values
 	      (cast-variable-values construct filter-variable-values))
-	(dolist (filter (filters construct))
-	  (let ((true-values nil))
-	    (dolist (var-elem filter-variable-values)
-	      (when (eval (read-from-string (to-lisp-code var-elem filter)))
-		(map 'list #'(lambda(list-elem)
-			       (push list-elem true-values))
-		     var-elem)))
-	    (let ((values-to-remove
-		   (return-false-values filter-variable-values
-					(remove-duplicates true-values
-							   :test #'variable-list=))))
-	      (dolist (to-del values-to-remove)
-		(delete-rows-by-value construct (getf to-del :variable-name)
-				      (getf to-del :variable-value))))))))
+	(let ((true-values nil))
+	  (dolist (var-elem filter-variable-values)
+	    (when (eval (read-from-string (to-lisp-code var-elem filter)))
+	      (map 'list #'(lambda(list-elem)
+			     (push list-elem true-values))
+		   var-elem)))
+	  (let ((values-to-remove
+		 (return-false-values filter-variable-values
+				      (remove-duplicates true-values
+							 :test #'variable-list=))))
+	    (dolist (to-del values-to-remove)
+	      (delete-rows-by-value construct (getf to-del :variable-name)
+				    (getf to-del :variable-value)))))))
     construct))
 
 

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Wed Apr  6 16:53:10 2011
@@ -2406,7 +2406,8 @@
 		 "SELECT * WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
                    FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82
-                   FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1"
+                   FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1
+		   FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'"
 		 "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
       ;(is-true (= (length r-1) 2))



From lgiessmann at common-lisp.net  Thu Apr  7 09:22:22 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 07 Apr 2011 05:22:22 -0400
Subject: [isidorus-cvs] r423 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7lPy-0004Vl-JJ@common-lisp.net>

Author: lgiessmann
Date: Thu Apr  7 05:22:22 2011
New Revision: 423

Log:
TM-SPARQL: fixed another efficiency problem in the processing of filters

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Thu Apr  7 05:22:22 2011
@@ -152,8 +152,12 @@
     (ppcre:scan scanner local-str)))
 
 
+(defun filter-functions::write-to-symbol (name-string)
+  (common-lisp:intern (common-lisp:string-upcase name-string)))
+
+
 (defun filter-functions::bound(x)
-  (boundp x))
+  (boundp (filter-functions::write-to-symbol x)))
 
 
 (defun filter-functions::isLITERAL(x)

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Thu Apr  7 05:22:22 2011
@@ -394,14 +394,22 @@
 (defun return-false-values (all-values true-values)
   "Returns a list that contains all values from all-values that
    are not contained in true-values."
-  (let ((local-all-values
-	 (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values)
-			    :test #'variable-list=))
-	(results nil))
-    (dolist (value local-all-values)
-      (when (not (find value true-values :test #'variable-list=))
-	(push value results)))
-    results))
+  (cond ((not all-values)
+	 nil)
+	((not true-values)
+	 (let ((local-all-values
+		(remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values)
+				   :test #'variable-list=)))
+	   local-all-values))
+	(t
+	 (let ((local-all-values
+		(remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values)
+				   :test #'variable-list=))
+	       (results nil))
+	   (dolist (value local-all-values)
+	     (when (not (find value true-values :test #'variable-list=))
+	       (push value results)))
+	   results))))
 
 
 (defun variable-list= (x y)
@@ -413,15 +421,16 @@
 
 (defgeneric process-filters (construct)
   (:documentation "Processes all filters by calling invoke-filter.")
-  (:method ((construct SPARQL-Query))      
+  (:method ((construct SPARQL-Query))
     (dolist (filter (filters construct))
-      (let* ((filter-variable-names
-	      (get-variables-from-filter-string filter))
-	     (filter-variable-values nil))
+      (let ((filter-variable-names (get-variables-from-filter-string filter))
+	    (filter-variable-values nil))
 	(dolist (var-name filter-variable-names)
 	  (setf filter-variable-values
 		(make-variable-values construct var-name filter-variable-values)))
 	(setf filter-variable-values
+	      (remove-duplicates-from-variable-list construct filter-variable-values))
+	(setf filter-variable-values
 	      (cast-variable-values construct filter-variable-values))
 	(let ((true-values nil))
 	  (dolist (var-elem filter-variable-values)
@@ -435,8 +444,41 @@
 							 :test #'variable-list=))))
 	    (dolist (to-del values-to-remove)
 	      (delete-rows-by-value construct (getf to-del :variable-name)
-				    (getf to-del :variable-value)))))))
-    construct))
+				    (getf to-del :variable-value)))))))))
+
+
+(defgeneric remove-duplicates-from-variable-list (construct variable-list)
+  (:documentation "Removes all duplicates from the passed variable list")
+  (:method ((construct SPARQL-QUERY) (variable-list LIST))
+    (remove-duplicates
+     variable-list
+     :test #'(lambda(x y)
+	       (when (= (length x) (length y))
+		 (let ((result nil))
+		   (dotimes (idx (length x) result)
+		     (let ((cx (elt x idx))
+			   (cy (elt y idx)))
+		       (when (or (string/= (getf cx :variable-name)
+					   (getf cy :variable-name))
+				 (and (getf cx :literal-datatype)
+				      (getf cy :literal-datatype)
+				      (string/= (getf cx :literal-datatype)
+						(getf cy :literal-datatype)))
+				 (and (getf cx :literal-datatype)
+				      (not (getf cy :literal-datatype)))
+				 (and (not (getf cx :literal-datatype))
+				      (getf cy :literal-datatype))
+				 (and (getf cx :variable-value)
+				      (getf cy :variable-value)
+				      (string/= (getf cx :variable-value)
+						(getf cy :variable-value)))
+				 (and (getf cx :variable-value)
+				      (not (getf cy :variable-value)))
+				 (and (not (getf cx :variable-value))
+				      (getf cy :variable-value)))
+			 (setf idx (length x))))
+		     (when (= idx (max 0 (1- (length x))))
+		       (setf result t)))))))))
 
 
 (defgeneric idx-of (construct variable-name variable-value &key what)

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Thu Apr  7 05:22:22 2011
@@ -230,11 +230,27 @@
 		 (arg-list (bracket-scope cleaned-right-str))
 		 (cleaned-arg-list (clean-function-arguments arg-list))
 		 (modified-str
-		  (concat
-		   left-str "(" fun-name " " cleaned-arg-list ")"
-		   (subseq right-str (+ (- (length right-str)
-					   (length cleaned-right-str))
-					(length arg-list))))))
+		  (let ((modified-arg-list
+			 (if (string= fun-name "BOUND")
+			     (let* ((var-start
+				     (search-first (list "?" "$") cleaned-arg-list))
+				    (var-end
+				     (when var-start
+				       (search-first
+					(list ")")
+					(subseq cleaned-arg-list var-start)))))
+			       (when (and var-start var-end)
+				 (concat (subseq cleaned-arg-list 0 var-start)
+					 "\"" (subseq cleaned-arg-list var-start
+						      (+ var-start var-end))
+					 "\"" (subseq cleaned-arg-list
+						      (+ var-start var-end)))))
+			     cleaned-arg-list)))
+		    (concat
+		     left-str "(" fun-name " " modified-arg-list ")"
+		     (subseq right-str (+ (- (length right-str)
+					     (length cleaned-right-str))
+					  (length arg-list)))))))
 	    (set-functions construct modified-str))))))
 
 
@@ -1000,20 +1016,33 @@
   (let ((variables nil))
     (dotimes (idx (length filter-string))
       (let ((current-string (subseq filter-string idx)))
-	(when (and (or (string-starts-with current-string "?")
-		       (string-starts-with current-string "$"))
-		   (not (in-literal-string-p filter-string idx)))
-	  (let ((end-pos
-		 (let ((inner-value
-			(search-first
-			 (append (list " " "?" "$" "." ",")
-				 (*supported-operators*)
-				 *supported-brackets*
-				 (map 'list #'string (white-space)))
-			 (subseq current-string 1))))
-		   (if inner-value
-		       (1+ inner-value)
-		       (length current-string)))))
-	    (push (subseq current-string 1 end-pos) variables)
-	    (incf idx end-pos)))))
+	(cond ((and (or (string-starts-with current-string "?")
+			(string-starts-with current-string "$"))
+		    (not (in-literal-string-p filter-string idx)))
+	       (let ((end-pos
+		      (let ((inner-value
+			     (search-first
+			      (append (list " " "?" "$" "." ",")
+				      (*supported-operators*)
+				      *supported-brackets*
+				      (map 'list #'string (white-space)))
+			      (subseq current-string 1))))
+			(if inner-value
+			    (1+ inner-value)
+			    (length current-string)))))
+		 (push (subseq current-string 1 end-pos) variables)
+		 (incf idx end-pos)))
+	      ;BOUND needs a separate hanlding since all variables
+	      ;      were written into strings so they have to be
+              ;      searched different
+	      ((and (string-starts-with current-string "BOUND ")
+		    (not (in-literal-string-p filter-string idx)))
+	       (let* ((next-str (subseq current-string (length "BOUND ")))
+		      (literal (when (string-starts-with next-str "\"")
+				 (let ((val (get-literal next-str)))
+				   (when val
+				     (getf val :literal))))))
+		 (when (and literal (> (length literal) 3)) ;"?.." | "$.."
+		   (push (subseq (string-trim (list #\") literal) 1) variables))
+		 (incf idx (+ (length "BOUND ") (length literal))))))))
     (remove-duplicates variables :test #'string=)))
\ No newline at end of file

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Thu Apr  7 05:22:22 2011
@@ -1530,7 +1530,7 @@
     (is-true result-5) (is-true result-5-2) (is-true result-5-3)
     (is-true result-5-4) (is-true result-5-5) (is-true result-5-6)
     (is (string= (string-replace result-1-6 " " "")
-		 "(or(progn(BOUND(progn(progn?var))))(progn(progn(and(progn(isLITERAL$var))(progn(=?var\"abc\"))))))"))
+		 "(or(progn(BOUND(progn(progn\"?var\"))))(progn(progn(and(progn(isLITERAL$var))(progn(=?var\"abc\"))))))"))
     (is (string= (string-replace result-2-6 " " "")
 		 "(progn(or(progn(REGEX?var1\"\"?var3))(progn(progn(and(progn(>?var1?var3))(progn(progn(=(STR?var)\"abc\"))))))))"))
     (is (string= (string-replace result-3-6 " " "")



From lgiessmann at common-lisp.net  Thu Apr  7 11:23:13 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 07 Apr 2011 07:23:13 -0400
Subject: [isidorus-cvs] r424 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q7nIv-0007jx-I6@common-lisp.net>

Author: lgiessmann
Date: Thu Apr  7 07:23:13 2011
New Revision: 424

Log:
TM-SPARQL: fixed a bug with the FILTER function BOUND; fixed also a performance problem when using defvar in functions, so now defvar is replaced by let followed by a (declare (Special <vars>)) command

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Thu Apr  7 07:23:13 2011
@@ -368,6 +368,38 @@
 				(elt (getf results :result) idx)))))))))
 
 
+;(defun to-lisp-code (variable-values filter)
+;  "Concatenates all variable names and elements with the filter expression
+;   in a let statement and returns a string representing the corresponding
+;   lisp code."
+;  (declare (List variable-values))
+;  (let ((result "")
+;	(cleanup-str ""))
+;    (dolist (var-elem variable-values)
+;      (push-string
+;       (concat "(defvar ?" (getf var-elem :variable-name) " "
+;	       (write-to-string (getf var-elem :variable-value)) ")")
+;       result)
+;      (push-string
+;       (concat "(defvar $" (getf var-elem :variable-name) " "
+;	       (write-to-string (getf var-elem :variable-value)) ")")
+;       result))
+;    (push-string "(let* ((true t)(false nil)" result)
+;    (push-string (concat "(result " filter "))") result)
+;    (push-string "(declare (Ignorable true false " result)
+;    (push-string "))" result)
+;    (dolist (var-elem variable-values)
+;      (push-string (concat "(makunbound '?" (getf var-elem :variable-name) ")")
+;		   cleanup-str)
+;      (push-string (concat "(makunbound '$" (getf var-elem :variable-name) ")")
+;		   cleanup-str))
+;    (push-string "(in-package :cl-user)" cleanup-str)
+;    (push-string cleanup-str result)
+;    (push-string "result)" result)
+;    (concat "(handler-case (progn " result ") (condition () (progn " cleanup-str
+;	    "nil)))")))
+
+
 (defun to-lisp-code (variable-values filter)
   "Concatenates all variable names and elements with the filter expression
    in a let statement and returns a string representing the corresponding
@@ -386,6 +418,12 @@
     (when variable-values
       (dolist (var-elem variable-values)
 	(push-string (concat "?" (getf var-elem :variable-name) " ") result)
+	(push-string (concat "$" (getf var-elem :variable-name) " ") result))
+      (push-string ")" result))
+    (when variable-values
+      (push-string "(Special " result)
+      (dolist (var-elem variable-values)
+	(push-string (concat "?" (getf var-elem :variable-name) " ") result)
 	(push-string (concat "$" (getf var-elem :variable-name) " ") result)))
     (push-string ")) result)" result)
     (concat "(handler-case " result " (condition () nil))")))

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Thu Apr  7 07:23:13 2011
@@ -235,10 +235,14 @@
 			     (let* ((var-start
 				     (search-first (list "?" "$") cleaned-arg-list))
 				    (var-end
-				     (when var-start
-				       (search-first
-					(list ")")
-					(subseq cleaned-arg-list var-start)))))
+				     (let ((val
+					    (when var-start
+					      (search-first
+					       (list ")")
+					       (subseq cleaned-arg-list var-start)))))
+				       (if val
+					   val
+					   (length (subseq cleaned-arg-list var-start))))))
 			       (when (and var-start var-end)
 				 (concat (subseq cleaned-arg-list 0 var-start)
 					 "\"" (subseq cleaned-arg-list var-start

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Thu Apr  7 07:23:13 2011
@@ -2407,7 +2407,8 @@
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
                    FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82
                    FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1
-		   FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'"
+		   FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'
+                   FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)"
 		 "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
       ;(is-true (= (length r-1) 2))



From lgiessmann at common-lisp.net  Thu Apr  7 19:19:16 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 07 Apr 2011 15:19:16 -0400
Subject: [isidorus-cvs] r425 - in trunk/src: TM-SPARQL base-tools unit_tests
Message-ID: <E1Q7ujc-0006SE-Ab@common-lisp.net>

Author: lgiessmann
Date: Thu Apr  7 15:19:16 2011
New Revision: 425

Log:
TM-SPARQL: fixed a bug in the function in-literal-string-p

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/TM-SPARQL/sparql_filter.lisp
   trunk/src/base-tools/base-tools.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Thu Apr  7 15:19:16 2011
@@ -187,10 +187,11 @@
 
 
 (defun filter-functions::str(x)
-  (if (stringp x)
-      (if (and (base-tools:string-starts-with x "<")
-	       (base-tools:string-ends-with x ">")
-	       (base-tools:absolute-uri-p (subseq x 1 (1- (length x)))))
-	  (subseq x 1 (1- (length x)))
-	  x)
-      (write-to-string x)))
\ No newline at end of file
+  ;(if (stringp x) ;TODO: remove
+  ;(if (and (base-tools:string-starts-with x "<")
+  ;(base-tools:string-ends-with x ">")
+  ;(base-tools:absolute-uri-p (subseq x 1 (1- (length x)))))
+  ;(subseq x 1 (1- (length x)))
+  ;x)
+  ;(write-to-string x)))
+  (write-to-string x))
\ No newline at end of file

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Thu Apr  7 15:19:16 2011
@@ -368,38 +368,6 @@
 				(elt (getf results :result) idx)))))))))
 
 
-;(defun to-lisp-code (variable-values filter)
-;  "Concatenates all variable names and elements with the filter expression
-;   in a let statement and returns a string representing the corresponding
-;   lisp code."
-;  (declare (List variable-values))
-;  (let ((result "")
-;	(cleanup-str ""))
-;    (dolist (var-elem variable-values)
-;      (push-string
-;       (concat "(defvar ?" (getf var-elem :variable-name) " "
-;	       (write-to-string (getf var-elem :variable-value)) ")")
-;       result)
-;      (push-string
-;       (concat "(defvar $" (getf var-elem :variable-name) " "
-;	       (write-to-string (getf var-elem :variable-value)) ")")
-;       result))
-;    (push-string "(let* ((true t)(false nil)" result)
-;    (push-string (concat "(result " filter "))") result)
-;    (push-string "(declare (Ignorable true false " result)
-;    (push-string "))" result)
-;    (dolist (var-elem variable-values)
-;      (push-string (concat "(makunbound '?" (getf var-elem :variable-name) ")")
-;		   cleanup-str)
-;      (push-string (concat "(makunbound '$" (getf var-elem :variable-name) ")")
-;		   cleanup-str))
-;    (push-string "(in-package :cl-user)" cleanup-str)
-;    (push-string cleanup-str result)
-;    (push-string "result)" result)
-;    (concat "(handler-case (progn " result ") (condition () (progn " cleanup-str
-;	    "nil)))")))
-
-
 (defun to-lisp-code (variable-values filter)
   "Concatenates all variable names and elements with the filter expression
    in a let statement and returns a string representing the corresponding
@@ -1409,22 +1377,24 @@
 		     &key (back-as-string-when-unsupported nil))
   "A helper function that casts the passed string value of the literal
    corresponding to the passed literal-type."
-  (declare (String literal-value literal-type)
+  (declare (String literal-value)
+	   (type (or String null) literal-type)
 	   (Boolean back-as-string-when-unsupported))
-  (cond ((string= literal-type *xml-string*)
-	 literal-value)
-	((string= literal-type *xml-boolean*)
-	 (cast-literal-to-boolean literal-value))
-	((string= literal-type *xml-integer*)
-	 (cast-literal-to-integer literal-value))
-	((string= literal-type *xml-double*)
-	 (cast-literal-to-double literal-value))
-	((string= literal-type *xml-decimal*)
-	 (cast-literal-to-decimal literal-value))
-	(t ; return the value as a string
-	 (if back-as-string-when-unsupported
-	     literal-value
-	     (concat "\"\"\"" literal-value "\"\"\"^^" literal-type)))))
+  (let ((local-literal-type (if literal-type literal-type *xml-string*)))
+    (cond ((string= local-literal-type *xml-string*)
+	   literal-value)
+	  ((string= local-literal-type *xml-boolean*)
+	   (cast-literal-to-boolean literal-value))
+	  ((string= local-literal-type *xml-integer*)
+	   (cast-literal-to-integer literal-value))
+	  ((string= local-literal-type *xml-double*)
+	   (cast-literal-to-double literal-value))
+	  ((string= local-literal-type *xml-decimal*)
+	   (cast-literal-to-decimal literal-value))
+	  (t ; return the value as a string
+	   (if back-as-string-when-unsupported
+	       literal-value
+	       (concat "\"\"\"" literal-value "\"\"\"^^" local-literal-type))))))
 
 
 (defun cast-literal-to-decimal (literal-value)

Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp	Thu Apr  7 15:19:16 2011
@@ -350,12 +350,24 @@
 	      (+ inner-value (1+ (length (name-after-paranthesis
 					  (subseq left-string inner-value))))))))
 	 (paranthesis-pair-idx
-	  (let* ((cleaned-str (trim-whitespace-right left-string))
-		 (bracket-scope (reverse-bracket-scope cleaned-str)))
-	    (when bracket-scope
-	      (- (- (length left-string)
-		    (- (length left-string) (length cleaned-str)))
-		 (length bracket-scope)))))
+	  (let ((value
+		 (let* ((cleaned-str (trim-whitespace-right left-string))
+			(bracket-scope (reverse-bracket-scope cleaned-str)))
+		   (when bracket-scope
+		     (- (- (length left-string)
+			   (- (length left-string) (length cleaned-str)))
+			(length bracket-scope))))))
+	    (when value ;search a functionname: FUN(...)
+	      (let* ((str-before (subseq left-string 0 value))
+		     (c-str-before (trim-whitespace-right str-before)))
+		(if (string-ends-with-one-of c-str-before *supported-functions*)
+		    (loop for fun-name in *supported-functions*
+		       when (string-ends-with c-str-before fun-name)
+		       return (- value
+				 (+ (- (length str-before)
+				       (length c-str-before))
+				    (length fun-name))))
+		    value)))))
 	 (start-idx (or first-bracket paranthesis-pair-idx 0)))
     (subseq left-string start-idx)))
 

Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp	(original)
+++ trunk/src/base-tools/base-tools.lisp	Thu Apr  7 15:19:16 2011
@@ -352,12 +352,8 @@
 		  (search-first (list "\"" "'") (subseq main-string 0 first-pos)
 				:from-end from-end))
 		 (next-str
-		  (if from-end
-		      
-
+		  (if from-end		      
 		      (subseq main-string 0 literal-start)
-		      
-		      
 		      (let* ((sub-str (subseq main-string literal-start))
 			     (literal-result (get-literal sub-str)))
 			(getf literal-result :next-string)))))
@@ -441,31 +437,25 @@
   (let ((result nil))
     (dotimes (idx (length filter-string) result)
       (let* ((current-str (subseq filter-string idx))
-	     (delimiter (cond ((string-starts-with current-str "'''")
-			       "'''")
-			      ((string-starts-with current-str "'")
-			       "'")
-			      ((string-starts-with current-str "\"\"\"")
-			       "\"\"\"")
-			      ((string-starts-with current-str "\"")
-			       "\""))))
+	     (delimiter (get-literal-quotation current-str)))
 	(when delimiter
 	  (let* ((end-pos
 		  (let ((result
-			 (search-first (list delimiter) 
-				       (subseq current-str (length delimiter)))))
-		    (when result
+			 (find-literal-end (subseq current-str (length delimiter))
+				    delimiter)))
+		  (when result
 		      (+ (length delimiter) result))))
 		 (quoted-str (when end-pos
 			       (subseq current-str (length delimiter) end-pos)))
 		 (start-pos idx))
-	    (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))
-	    (if (and (>= pos start-pos)
-		     (<= pos (+ start-pos end-pos)))
-		(progn
-		  (setf result t)
-		  (setf idx (length filter-string)))
-		(incf idx (+ (* 2 (length delimiter)) (length quoted-str))))))))))
+	    (when quoted-str
+	      (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))
+	      (if (and (>= pos start-pos)
+		       (< pos (+ start-pos end-pos)))
+		  (progn
+		    (setf result t)
+		    (setf idx (length filter-string)))
+		  (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))))))))))
 
 
 (defun search-first-unclosed-paranthesis (str &key (ignore-literals t))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Thu Apr  7 15:19:16 2011
@@ -1549,7 +1549,7 @@
 	      "BASE <http://some.where/psis/poem/>
                SELECT $subject ?predicate WHERE{
                 ?subject $predicate <zauberlehrling> .
-                FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}")
+                FILTER (STR(?predicate) = '\"<http://some.where/base-psis/written>\"')}")
 	     (query-2 "SELECT ?object ?subject WHERE{
                         <http://some.where/psis/author/goethe> ?predicate ?object .
                         FILTER (isLITERAL(?object) &&
@@ -2408,7 +2408,9 @@
                    FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82
                    FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1
 		   FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'
-                   FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)"
+                   FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)
+		   FILTER (DATATYPE(?obj1) = '" *xml-string* "' || DATATYPE(?obj1) = '" *xml-integer* "') && !(DATATYPE(?obj1) = '" *xml-double* "')
+                   FILTER STR(?obj1) = '82' || ?obj1='von Goethe'"
 		 "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
       ;(is-true (= (length r-1) 2))



From lgiessmann at common-lisp.net  Fri Apr  8 08:49:15 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Fri, 08 Apr 2011 04:49:15 -0400
Subject: [isidorus-cvs] r426 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1Q87NT-0006vW-6S@common-lisp.net>

Author: lgiessmann
Date: Fri Apr  8 04:49:14 2011
New Revision: 426

Log:
TM-SPARQL: finished the implementation of the SPARQL-API; finished the unit-tests of the SPARQL-API

Modified:
   trunk/src/TM-SPARQL/filter_wrappers.lisp
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- trunk/src/TM-SPARQL/filter_wrappers.lisp	(original)
+++ trunk/src/TM-SPARQL/filter_wrappers.lisp	Fri Apr  8 04:49:14 2011
@@ -10,7 +10,7 @@
 
 (defpackage :filter-functions
   (:use :base-tools :constants :tm-sparql)
-  (:import-from :cl progn handler-case let))
+  (:import-from :cl progn handler-case let condition))
 
 
 (defun filter-functions::normalize-value (value)
@@ -149,7 +149,8 @@
 				:case-insensitive-mode case-insensitive
 				:multi-line-mode multi-line
 				:single-line-mode single-line)))
-    (ppcre:scan scanner local-str)))
+    (when (ppcre:scan scanner local-str)
+      t)))
 
 
 (defun filter-functions::write-to-symbol (name-string)
@@ -187,11 +188,4 @@
 
 
 (defun filter-functions::str(x)
-  ;(if (stringp x) ;TODO: remove
-  ;(if (and (base-tools:string-starts-with x "<")
-  ;(base-tools:string-ends-with x ">")
-  ;(base-tools:absolute-uri-p (subseq x 1 (1- (length x)))))
-  ;(subseq x 1 (1- (length x)))
-  ;x)
-  ;(write-to-string x)))
-  (write-to-string x))
\ No newline at end of file
+   (write-to-string x))
\ No newline at end of file

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Fri Apr  8 04:49:14 2011
@@ -511,13 +511,13 @@
 	  (variable-p
 	   (cond ((eql what :subject)
 		  (and (variable-p (subject construct))
-		       (value (subject construct))))
+		       (string= (value (subject construct)) variable-name)))
 		 ((eql what :predicate)
 		  (and (variable-p (predicate construct))
-		       (value (predicate construct))))
+		       (string=  (value (predicate construct)) variable-name)))
 		 ((eql what :object)
 		  (and (variable-p (object construct))
-		       (value (object construct)))))))
+		       (string= (value (object construct)) variable-name))))))
       (when variable-p
 	(remove-null
 	 (dotimes (idx (length local-results))

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Fri Apr  8 04:49:14 2011
@@ -2403,18 +2403,45 @@
   (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*)
     (tm-sparql:init-tm-sparql)
     (let* ((q-1 (concat
-		 "SELECT * WHERE {
+		 "SELECT ?pred1 ?obj3 ?obj1 WHERE {
                    <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1.
                    FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82
                    FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1
 		   FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'
                    FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)
 		   FILTER (DATATYPE(?obj1) = '" *xml-string* "' || DATATYPE(?obj1) = '" *xml-integer* "') && !(DATATYPE(?obj1) = '" *xml-double* "')
-                   FILTER STR(?obj1) = '82' || ?obj1='von Goethe'"
+                   FILTER STR(?obj1) = '82' || ?obj1='von Goethe'
+                   FILTER ?obj1 = 82 || REGEX(STR(?obj1), 'von G.*')
+                   ?subj3 <" *tms-value* "> ?obj3.
+                   FILTER REGEX(?obj3, 'e.+e.+')"
 		 "}"))
 	   (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))))
-      ;(is-true (= (length r-1) 2))
-      (format t "~a~%" r-1))))
+      (is-true (= (length r-1) 3))
+      (map 'list #'(lambda(item)
+		     (cond
+		       ((string= (getf item :variable) "pred1")
+			(is (= (length (getf item :result)) 2))
+			(is (find "<http://some.where/tmsparql/last-name>"
+				  (getf item :result) :test #'string=))
+			(is (find "<http://some.where/tmsparql/years>"
+				  (getf item :result) :test #'string=)))
+		       ((string= (getf item :variable) "obj1")
+			(is (= (length (getf item :result)) 2))
+			(is (find 82 (getf item :result) :test #'tm-sparql::literal=))
+			(is (find "von Goethe" (getf item :result)
+				  :test #'tm-sparql::literal=)))
+		       ((string= (getf item :variable) "obj3")
+			(is (= (length (getf item :result)) 2))
+			(is-true (find "Der Zauberlehrling" (getf item :result)
+				  :test #'string=))
+			(is-true (find "Hat der alte Hexenmeister
+	sich doch einmal wegbegeben!
+	..." (getf item :result) :test #'string=)))
+		       (t
+			(is-true (format t "bad variable-name found ~a"
+					 (getf item :variable))))))
+	   
+	   r-1))))
 
 
 



From lgiessmann at common-lisp.net  Thu Apr 21 09:56:59 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Thu, 21 Apr 2011 05:56:59 -0400
Subject: [isidorus-cvs] r427 - in trunk/src: ajax/javascripts json model
	rest_interface
Message-ID: <E1QCqd9-0001V1-FN@common-lisp.net>

Author: lgiessmann
Date: Thu Apr 21 05:56:59 2011
New Revision: 427

Log:
JSON-Interface: all / that are not escaped will be escaped after calling prototypes toJSON method, because prototype does not escape /; if no topics for a player-constraint or other-player-constraint exist there is no error message thrown, instead the constraint is ignored as long as there are to few topics; the backend now escapes all /, too

Modified:
   trunk/src/ajax/javascripts/create.js
   trunk/src/ajax/javascripts/datamodel.js
   trunk/src/ajax/javascripts/requests.js
   trunk/src/ajax/javascripts/tmcl_tools.js
   trunk/src/json/json_exporter.lisp
   trunk/src/model/changes.lisp
   trunk/src/rest_interface/set-up-json-interface.lisp

Modified: trunk/src/ajax/javascripts/create.js
==============================================================================
--- trunk/src/ajax/javascripts/create.js	(original)
+++ trunk/src/ajax/javascripts/create.js	Thu Apr 21 05:56:59 2011
@@ -130,7 +130,8 @@
 	    alert("The fragment wasn't committed - Please correct your input data!");
 	    return;
 	}
-	
+
+
 	// --- if the validation succeeded the fragment will be sent to the server
 	var tPsis = topic.getContent().subjectIdentifiers;
 	if(!tPsis || tPsis.length === 0) tPsis = "null";
@@ -150,6 +151,7 @@
 	    referencedTopics = referencedTopics.concat(aStubs);
 	}
 
+
 	function onSuccessHandler(topicStubs){
 	    var tsStr = "null";
 	    if(topicStubs && topicStubs.length !== 0){
@@ -160,17 +162,19 @@
 		}
 		tsStr += "]";
 	    }
+    
 	    var jTopic = "\"topic\":" + topic.toJSON();
 	    var jTopicStubs = "\"topicStubs\":" + tsStr;
 	    var jAssociations = "\"associations\":" + (associations ? associations.toJSON().gsub("\\[\"" + CURRENT_TOPIC_ESCAPED + "\"\\]", tPsis) : "null");
 	    var jTmId = "\"tmIds\":" + tmId.toJSON();
 	    var json = "{" + jTopic + "," + jTopicStubs + "," + jAssociations + "," + jTmId + "}";
+
 	    commitFragment(json, function(xhr){ alert("The fragment was committed succesfully!"); }, null);
 	}
-	
+		
 	function onErrorHandler(){
 	    // --- currently there is not needed a special handling for errors
-	    // --- occurred during this operation
+	    // --- occurring during this operation
 	}
 	getTopicStubs(referencedTopics, onSuccessHandler, onErrorHandler);
     });

Modified: trunk/src/ajax/javascripts/datamodel.js
==============================================================================
--- trunk/src/ajax/javascripts/datamodel.js	(original)
+++ trunk/src/ajax/javascripts/datamodel.js	Thu Apr 21 05:56:59 2011
@@ -549,7 +549,8 @@
 					    },
 					    "toJSON" : function(unique, removeNull){
 						var content = this.getContent(unique, removeNull);
-						return content.length === 0 ? "null" : content.toJSON();
+						if(!content || content.length === 0) return "null";
+						return content.toJSON();
 					    },
 					    "isValid" : function(){
 						var allIdentifiers = new Array();
@@ -2665,8 +2666,8 @@
 						       this.__createFromContent__(contents);
 						   }
                                                    catch(err){
-                                               	       alert("From RoleContainerC(): " + err);
-                                                   }
+						       alert("From RoleContainerC(): " + err);
+						   }
                                                },
 					       "__orderContentsToRoles__" : function(contents, roleContainer, usedContents, alreadyUsedRoles){
 						   if(!roleContainer || roleContainer.length === 0){
@@ -2920,31 +2921,31 @@
 						   var cContents = contents;
 						   var usedContents = new Array();
 						   var alreadyUsedRoles = new Array();
-						       
+						      
 						   // --- searches for associaitonrole-constraints and roleplayer-constraints
 						   var ret = this.__orderContentsToRoles__(cContents, this.__arContainer__.__frames__, usedContents, alreadyUsedRoles);
 						   cContents = ret.contents;
 						   usedContents = ret.usedContents;
 						   alreadyUsedRoles = ret.alreadyUsedRoles;
-
+						 
 						   // --- searches for otherrole-constraints
 						   ret = this.__orderContentsToRoles__(cContents, this.__orContainer__.__frames__, usedContents, alreadyUsedRoles);
 						   cContents = ret.contents;
 						   usedContents = ret.usedContents;
 						   alreadyUsedRoles = ret.alreadyUsedRoles;
-						   
+						  
 						   // --- creates additional roles (associationrole-constraints)
 						   ret = this.__createAdditionalRolesFromContents__(cContents, usedContents, alreadyUsedRoles, true);
 						   cContents = ret.contents;
 						   usedContents = ret.usedContents;
 						   alreadyUsedRoles = ret.alreadyUsedRoles;
-
+						  
 						   // --- creates additional roles (associationrole-constraints)
 						   ret = this.__createAdditionalRolesFromContents__(cContents, usedContents, alreadyUsedRoles, false);
 						   cContents = ret.contents;
 						   usedContents = ret.usedContents;
 						   alreadyUsedRoles = ret.alreadyUsedRoles;
-
+						  
 						   this.__createNewRolesFromContents__(cContents);
 					       },
 					       "resetValues" : function(associationRoleConstraints, rolePlayerConstraints, otherRoleConstraints){
@@ -2994,8 +2995,11 @@
 						   var roleMin = associationRoleConstraint.cardMin === 0 ? 1 : parseInt(associationRoleConstraint.cardMin);
 						   var roleMinOrg = parseInt(associationRoleConstraint.cardMin);
 						   for(var i = 0; i !== rolePlayerConstraints.length; ++i){
+						       // if no player is available for a rolePlayerConstraint the constraint is ignored and no warning is thrown
+						       if(!rolePlayerConstraints[i].players || rolePlayerConstraints[i].players.length < playerMin) continue;
+						       
+
 						       var playerMin = rolePlayerConstraints[i].cardMin === 0 ? 1 : parseInt(rolePlayerConstraints[i].cardMin);
-						       if(rolePlayerConstraints[i].players.length < playerMin) throw "From __makeRolesFromARC__(): not enough players(=" + rolePlayerConstraints[i].players.length + ") to reach card-min(=" + playerMin + ") of roletype\"" + roleType.flatten()[0] + "\"!";
 						       for(var k = 0; k !== playerMin; ++k){
 							   // --- creates a new role
 							   var selectedPlayers = new Array();
@@ -3022,7 +3026,7 @@
 						       for(var i= 0; i !== rolePlayerConstraints.length; ++i){
 							   // existing roles --> all roles that owns a player which is selected of those listed in the roleplayer-constraint
 							   var existingRoles = this.getExistingRoles(roleType, rolePlayerConstraints[i].players, this.__arContainer__.__frames__);
-							   var availablePlayers = rolePlayerConstraints[i].players;
+							   var availablePlayers = (rolePlayerConstraints[i].players ? rolePlayerConstraints[i].players : new Array());
 							   if(existingRoles.length < rolePlayerConstraints[i].cardMax && availablePlayers.length > existingRoles.length){
 							       var currentAvailablePlayers = rolePlayerConstraints[i].players;
 							       var cleanedPlayers = cleanPlayers(allAvailablePlayers, currentAvailablePlayers);
@@ -3047,7 +3051,9 @@
 							       ++currentlyCreated;
 							   }
 						       }
-						       if(currentlyCreated === 0) throw "Not enough players to create all needed roles of the type \"" + roleType.flatten()[0] + "\"!";
+
+						       // not enough roles created so an association with zero roles can be made
+						       if(currentlyCreated === 0) break;
 						   };
 						   this.__checkARCButtons__(currentRoles, allAvailablePlayers, associationRoleConstraint);
 						   for(var i = 0; i !== currentRoles.length; ++i){
@@ -3064,7 +3070,11 @@
 						       var cOtherRoleType = orpcs[i].otherRoleType;
 						       var cMin = orpcs[i].cardMin === 0 ? 1 : parseInt(orpcs[i].cardMin);
 						       var cMinOrg = parseInt(orpcs[i].cardMin);
-						       if(!cOtherPlayers || cOtherPlayers.length < cMin) throw "from __makeRolesFromORC__(): not enough players(=" + cOtherPlayers.length + ") for roletype + \"" + cOtherRoleType.flatten()[0] + "\"!";
+
+						       // if there are not enough other players  the constraint is ignored and no error message is thrown
+						       if(!cOtherPlayers || cOtherPlayers.length < cMin) continue;
+
+
 						       var existingRoles = this.getExistingRoles(cOtherRoleType, cOtherPlayers, this.__orContainer__.__frames__);
 						       for(var j = 0; j < cMin - existingRoles.length; ++j){
 							   // --- removes all players that are already selected from the
@@ -3471,7 +3481,7 @@
                                                    var orcs = this.__otherRoleConstraints__;
                                                    var rpcs = this.__rolePlayerConstraints__;
 						   
-						   // --- checks if there exist any constraints
+						   // --- checks if there exist aniy constraints
 						   if(!arcs || arcs.length === 0){
 						       this.showError("No association-constraints found for this association!");
 						       return false;
@@ -3485,20 +3495,24 @@
 						   // --- collects all used roles depending on associationrole-constraints
 						   var allAroles = new Array();
 						   var allAroles2 = new Array();
-						   for(var i = 0; this.__arContainer__.__frames__ && i !== this.__arContainer__.__frames__.length; ++i){
-						       this.__arContainer__.__frames__[i].hideError();
-						       if(this.__arContainer__.__frames__[i].isUsed() === true){
-							   allAroles.push(this.__arContainer__.__frames__[i]);
-							   allAroles2.push(this.__arContainer__.__frames__[i]);
+						   if(this.__arContainer__ && this.__arContainer__.__frames__){
+						       for(var i = 0; this.__arContainer__.__frames__ && i !== this.__arContainer__.__frames__.length; ++i){
+							   this.__arContainer__.__frames__[i].hideError();
+							   if(this.__arContainer__.__frames__[i].isUsed() === true){
+							       allAroles.push(this.__arContainer__.__frames__[i]);
+							       allAroles2.push(this.__arContainer__.__frames__[i]);
+							   }
 						       }
 						   }
 						   
 						   // --- collects all used roles depending on otherrole-constraints
 						   var allOroles = new Array();
-						   for(var i = 0; i !== this.__orContainer__.__frames__.length; ++i){
-						       this.__orContainer__.__frames__[i].hideError();
-						       if(this.__orContainer__.__frames__[i].isUsed() === true)
-							   allOroles.push(this.__orContainer__.__frames__[i]);
+						   if(this.__orContainer__ && this.__orContainer__.__frames__){
+						       for(var i = 0; i !== this.__orContainer__.__frames__.length; ++i){
+							   this.__orContainer__.__frames__[i].hideError();
+							   if(this.__orContainer__.__frames__[i].isUsed() === true)
+							       allOroles.push(this.__orContainer__.__frames__[i]);
+						       }
 						   }
 						   
 						   // --- checks all associationrole-constraints

Modified: trunk/src/ajax/javascripts/requests.js
==============================================================================
--- trunk/src/ajax/javascripts/requests.js	(original)
+++ trunk/src/ajax/javascripts/requests.js	Thu Apr 21 05:56:59 2011
@@ -10,6 +10,13 @@
 //+  trunk/src/ajax/javascripts/external/MIT-LICENSE.txt.
 //+-----------------------------------------------------------------------------
 
+
+// --- replaces every / character that is not prefixed by a \ character
+function escapeSlashInJSON(jsonString){
+    return jsonString.replace(/([^\\])\//g, '$1\\/').replace(/([^\\])\//g, '$1\\/');
+}
+
+
 // --- Sets a timeout function which alerts a message.
 function setAjaxTimeout(time, url)
 {
@@ -208,7 +215,7 @@
 	
 	new Ajax.Request(COMMIT_URL, {
 	    "method" : "post",
-	    "postBody" : json,
+	    "postBody" : escapeSlashInJSON(json),
 	    "onSuccess" : createXHRHandler(onSuccessHandler, timeFun),
 	    "onFailure" : createXHRHandler(onFailure, timeFun)});
     }
@@ -228,7 +235,7 @@
 	var timeFun = setAjaxTimeout(TIMEOUT, COMMIT_URL);
 	new Ajax.Request(MARK_AS_DELETED_URL, {
 	    "method" : "delete",
-	    "postBody" : json,
+	    "postBody" : escapeSlashInJSON(json),
 	    "onSuccess" : createXHRHandler(onSuccessHandler, timeFun),
 	    "onFailure" : createXHRHandler(onFailure, timeFun)});
     }

Modified: trunk/src/ajax/javascripts/tmcl_tools.js
==============================================================================
--- trunk/src/ajax/javascripts/tmcl_tools.js	(original)
+++ trunk/src/ajax/javascripts/tmcl_tools.js	Thu Apr 21 05:56:59 2011
@@ -163,6 +163,7 @@
     if(!anyConstraints || anyConstraints.length === 0) return players;
 
     for(var i = 0; i !== anyConstraints.length; ++i){
+	if(!anyConstraints[i].players) return players;
 	for(var j = 0; j !== anyConstraints[i].players.length; ++j){
 	    players.push(anyConstraints[i].players[j])
 	}

Modified: trunk/src/json/json_exporter.lisp
==============================================================================
--- trunk/src/json/json_exporter.lisp	(original)
+++ trunk/src/json/json_exporter.lisp	Thu Apr 21 05:56:59 2011
@@ -36,8 +36,9 @@
 	     (or (eql what 'psis)
 		 (eql what 'item-identifiers)
 		 (eql what 'locators)))
-    (let ((items 
-	   (map 'list #'uri (funcall what parent-construct :revision revision))))
+    (let ((items
+	   (map 'list #'uri
+		(funcall what parent-construct :revision revision))))
       (json:encode-json-to-string items))))
 
 

Modified: trunk/src/model/changes.lisp
==============================================================================
--- trunk/src/model/changes.lisp	(original)
+++ trunk/src/model/changes.lisp	Thu Apr 21 05:56:59 2011
@@ -37,10 +37,11 @@
   (:documentation "Finds all associations for a topic.")
   (:method ((instance TopicC) &key (revision *TM-REVISION*))
     (declare (type (or integer null) revision))
-    (remove-duplicates 
-     (map 'list #'(lambda(role)
-		    (parent role :revision revision))
-	  (player-in-roles instance :revision revision)))))
+    (remove-null
+     (remove-duplicates 
+      (map 'list #'(lambda(role)
+		     (parent role :revision revision))
+	   (player-in-roles instance :revision revision))))))
 
 
 (defgeneric find-associations (instance &key revision)

Modified: trunk/src/rest_interface/set-up-json-interface.lisp
==============================================================================
--- trunk/src/rest_interface/set-up-json-interface.lisp	(original)
+++ trunk/src/rest_interface/set-up-json-interface.lisp	Thu Apr 21 05:56:59 2011
@@ -548,7 +548,7 @@
     (let ((topictype (get-item-by-psi json-tmcl-constants::*topictype-psi*
 				      :revision 0))
 	  (topictype-constraint (json-tmcl::is-type-constrained :revision 0)))
-      (format t "~%initialize cache: ")
+      (format t "~%initializing cache: ")
       (map 'list #'(lambda(top)
 		     (format t ".")
 		     (push-to-cache top topictype topictype-constraint))
@@ -576,7 +576,7 @@
 
 (defun init-fragments ()
   "Creates fragments of all topics that have a PSI."
-  (format t "create fragments: ")
+  (format t "creating fragments: ")
   (map 'list #'(lambda(top)
 		 (let ((psis-of-top (psis top)))
 		   (when psis-of-top



From lgiessmann at common-lisp.net  Tue Apr 26 13:36:47 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 26 Apr 2011 09:36:47 -0400
Subject: [isidorus-cvs] r428 - in trunk/src: TM-SPARQL unit_tests
Message-ID: <E1QEiRa-0003fi-Vw@common-lisp.net>

Author: lgiessmann
Date: Tue Apr 26 09:36:46 2011
New Revision: 428

Log:
TM-SPARQL: added the possibility to search for triplles of the form "?var1 ?var2 ?var3" => adopted the corresponding unit-tests to this change

Modified:
   trunk/src/TM-SPARQL/sparql.lisp
   trunk/src/unit_tests/sparql_test.lisp

Modified: trunk/src/TM-SPARQL/sparql.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql.lisp	(original)
+++ trunk/src/TM-SPARQL/sparql.lisp	Tue Apr 26 09:36:46 2011
@@ -572,7 +572,8 @@
       (let ((results (append
 		      (or (filter-by-given-subject construct :revision revision)
 			  (filter-by-given-predicate construct :revision revision)
-			  (filter-by-given-object construct :revision revision))
+			  (filter-by-given-object construct :revision revision)
+			  (filter-by-variable-triple construct :revision revision))
 		      (filter-by-special-uris construct :revision revision))))
 	(map 'list #'(lambda(result)
 		       (push (getf result :subject) (subject-result construct))
@@ -583,6 +584,29 @@
 	     results)))))
 
 
+(defgeneric filter-by-variable-triple (construct &key revision)
+  (:documentation "Returns all graphs that match a triple consisting
+                   only of variables.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (when (and (variable-p (subject construct))
+	       (variable-p (predicate construct))
+	       (variable-p (object construct)))
+      (let ((all-possible-subjects
+	     (append (get-all-topics revision)
+		     (get-all-occurrences revision)
+		     (get-all-names revision)
+		     (get-all-variants revision)
+		     (get-all-associations revision)
+		     (get-all-roles revision))))
+	(remove-null
+	 (loop for subj in all-possible-subjects
+	    append (when (typep subj 'TopicC)
+		     (append (filter-characteristics
+			      subj nil nil nil :revision revision)
+			     (filter-associations
+			      subj nil nil :revision revision)))))))))
+
+
 (defgeneric filter-by-given-object (construct &key revision)
   (:documentation "Returns a list representing a triple that is the result
                    of a given object.")

Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp	(original)
+++ trunk/src/unit_tests/sparql_test.lisp	Tue Apr 26 09:36:46 2011
@@ -450,11 +450,11 @@
 	(is (= (length (tm-sparql::select-group q-obj-2)) 1))
 	(is-true q-obj-3)
 	(is (= (length (tm-sparql::select-group q-obj-3)) 1))
-	(is-false (tm-sparql::subject-result
+	(is-true (tm-sparql::subject-result
 		   (first (tm-sparql::select-group q-obj-1))))
-	(is-false (tm-sparql::predicate-result
+	(is-true (tm-sparql::predicate-result
 		   (first (tm-sparql::select-group q-obj-1))))
-	(is-false (tm-sparql::object-result
+	(is-true (tm-sparql::object-result
 		   (first (tm-sparql::select-group q-obj-1))))
 	(is (= (length (tm-sparql::subject-result
 			(first (tm-sparql::select-group q-obj-2)))) 2))



From lgiessmann at common-lisp.net  Tue Apr 26 14:21:23 2011
From: lgiessmann at common-lisp.net (Lukas Giessmann)
Date: Tue, 26 Apr 2011 10:21:23 -0400
Subject: [isidorus-cvs] r429 - in trunk/src: . json json/JTM
	json/isidorus-json
Message-ID: <E1QEj8l-0005gc-J4@common-lisp.net>

Author: lgiessmann
Date: Tue Apr 26 10:21:23 2011
New Revision: 429

Log:
json: moved the json module to json/isidorus-json; added the module json/JTM; added all initila files needed by the JTM module

Added:
   trunk/src/json/JTM/
   trunk/src/json/JTM/jtm_exporter.lisp
   trunk/src/json/JTM/jtm_importer.lisp
   trunk/src/json/JTM/jtm_tools.lisp
   trunk/src/json/isidorus-json/
   trunk/src/json/isidorus-json/json_delete_interface.lisp
      - copied unchanged from r331, /trunk/src/json/json_delete_interface.lisp
   trunk/src/json/isidorus-json/json_exporter.lisp
      - copied unchanged from r427, /trunk/src/json/json_exporter.lisp
   trunk/src/json/isidorus-json/json_importer.lisp
      - copied unchanged from r328, /trunk/src/json/json_importer.lisp
   trunk/src/json/isidorus-json/json_tmcl.lisp
      - copied unchanged from r384, /trunk/src/json/json_tmcl.lisp
   trunk/src/json/isidorus-json/json_tmcl_constants.lisp
      - copied unchanged from r328, /trunk/src/json/json_tmcl_constants.lisp
   trunk/src/json/isidorus-json/json_tmcl_validation.lisp
      - copied unchanged from r384, /trunk/src/json/json_tmcl_validation.lisp
Removed:
   trunk/src/json/json_delete_interface.lisp
   trunk/src/json/json_exporter.lisp
   trunk/src/json/json_importer.lisp
   trunk/src/json/json_tmcl.lisp
   trunk/src/json/json_tmcl_constants.lisp
   trunk/src/json/json_tmcl_validation.lisp
Modified:
   trunk/src/isidorus.asd

Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd	(original)
+++ trunk/src/isidorus.asd	Tue Apr 26 10:21:23 2011
@@ -200,16 +200,23 @@
 				     "base-tools"
 				     "TM-SPARQL"))
 	       (:module "json"
-	                :components ((:file "json_exporter"
-					    :depends-on ("json_tmcl_constants"))
-				     (:file "json_importer")
-				     (:file "json_tmcl_validation"
-					    :depends-on ("json_tmcl_constants" "json_exporter" "json_importer"))
-				     (:file "json_tmcl_constants")
-				     (:file "json_tmcl"
-					    :depends-on ("json_tmcl_validation" "json_importer"))
-				     (:file "json_delete_interface"
-					    :depends-on ("json_importer")))
+			:components ((:module "isidorus-json"
+					      :components ((:file "json_exporter"
+								  :depends-on ("json_tmcl_constants"))
+							   (:file "json_importer")
+							   (:file "json_tmcl_validation"
+								  :depends-on ("json_tmcl_constants" "json_exporter" "json_importer"))
+							   (:file "json_tmcl_constants")
+							   (:file "json_tmcl"
+								  :depends-on ("json_tmcl_validation" "json_importer"))
+							   (:file "json_delete_interface"
+								  :depends-on ("json_importer"))))
+				     (:module "JTM"
+					      :components ((:file "jtm_tools")
+							   (:file "jtm_importer"
+								  :depends-on ("jtm_tools"))
+							   (:file "jtm_exporter"
+								  :depends-on ("jtm_tools")))))
 	                :depends-on ("base-tools"
 				     "model"
 				     "xml"

Added: trunk/src/json/JTM/jtm_exporter.lisp
==============================================================================
--- (empty file)
+++ trunk/src/json/JTM/jtm_exporter.lisp	Tue Apr 26 10:21:23 2011
@@ -0,0 +1,11 @@
+;;+-----------------------------------------------------------------------------
+;;+  Isidorus
+;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+  Isidorus is freely distributable under the LLGPL license.
+;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+  trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+
+(in-package :jtm)
\ No newline at end of file

Added: trunk/src/json/JTM/jtm_importer.lisp
==============================================================================
--- (empty file)
+++ trunk/src/json/JTM/jtm_importer.lisp	Tue Apr 26 10:21:23 2011
@@ -0,0 +1,11 @@
+;;+-----------------------------------------------------------------------------
+;;+  Isidorus
+;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+  Isidorus is freely distributable under the LLGPL license.
+;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+  trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+
+(in-package :jtm)
\ No newline at end of file

Added: trunk/src/json/JTM/jtm_tools.lisp
==============================================================================
--- (empty file)
+++ trunk/src/json/JTM/jtm_tools.lisp	Tue Apr 26 10:21:23 2011
@@ -0,0 +1,18 @@
+;;+-----------------------------------------------------------------------------
+;;+  Isidorus
+;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
+;;+
+;;+  Isidorus is freely distributable under the LLGPL license.
+;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
+;;+  trunk/docs/LGPL-LICENSE.txt.
+;;+-----------------------------------------------------------------------------
+
+(defpackage :jtm
+  (:use :cl :json :datamodel)
+  (:export :jtm-import
+	   :jtm-export
+	   :*json-xtm*))
+
+(in-package :jtm)
+
+(defvar *jtm-xtm* "jtm-xtm"); Represents the currently active TM of the JTM-Importer
\ No newline at end of file