[isidorus-cvs] r395 - in trunk: playground/abcl-test playground/abcl-test/.settings playground/abcl-test/lib playground/abcl-test/lisp-code playground/abcl-test/lisp-code/TM-SPARQL playground/abcl-test/lisp-code/base-tools playground/abcl-test/lisp-code/test-code playground/abcl-test/src playground/abcl-test/src/program src/TM-SPARQL

Lukas Giessmann lgiessmann at common-lisp.net
Wed Feb 16 09:51:06 UTC 2011


Author: lgiessmann
Date: Wed Feb 16 04:51:06 2011
New Revision: 395

Log:
playground: added a project that uses some test cases with ABCL

Added:
   trunk/playground/abcl-test/
   trunk/playground/abcl-test/.classpath
   trunk/playground/abcl-test/.project
   trunk/playground/abcl-test/.settings/
   trunk/playground/abcl-test/.settings/org.eclipse.jdt.core.prefs
   trunk/playground/abcl-test/lib/
   trunk/playground/abcl-test/lib/abcl.jar   (contents, props changed)
   trunk/playground/abcl-test/lisp-code/
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/filter_wrappers.lisp
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql.lisp
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_constants.lisp
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_filter.lisp
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_parser.lisp
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_special_uris.lisp
   trunk/playground/abcl-test/lisp-code/TM-SPARQL/tmsparql_core_psis.xtm
   trunk/playground/abcl-test/lisp-code/base-tools/
   trunk/playground/abcl-test/lisp-code/base-tools/base-tools.lisp
   trunk/playground/abcl-test/lisp-code/test-code/
   trunk/playground/abcl-test/lisp-code/test-code/functions.lisp
   trunk/playground/abcl-test/src/
   trunk/playground/abcl-test/src/program/
   trunk/playground/abcl-test/src/program/Main.java
Modified:
   trunk/src/TM-SPARQL/sparql_special_uris.lisp

Added: trunk/playground/abcl-test/.classpath
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/.classpath	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,7 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<classpath>
+	<classpathentry kind="src" path="src"/>
+	<classpathentry kind="con" path="org.eclipse.jdt.launching.JRE_CONTAINER/org.eclipse.jdt.internal.debug.ui.launcher.StandardVMType/JavaSE-1.6"/>
+	<classpathentry kind="lib" path="lib/abcl.jar"/>
+	<classpathentry kind="output" path="bin"/>
+</classpath>

Added: trunk/playground/abcl-test/.project
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/.project	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,17 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<projectDescription>
+	<name>abcl-test</name>
+	<comment></comment>
+	<projects>
+	</projects>
+	<buildSpec>
+		<buildCommand>
+			<name>org.eclipse.jdt.core.javabuilder</name>
+			<arguments>
+			</arguments>
+		</buildCommand>
+	</buildSpec>
+	<natures>
+		<nature>org.eclipse.jdt.core.javanature</nature>
+	</natures>
+</projectDescription>

Added: trunk/playground/abcl-test/.settings/org.eclipse.jdt.core.prefs
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/.settings/org.eclipse.jdt.core.prefs	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,12 @@
+#Wed Feb 16 08:34:56 CET 2011
+eclipse.preferences.version=1
+org.eclipse.jdt.core.compiler.codegen.inlineJsrBytecode=enabled
+org.eclipse.jdt.core.compiler.codegen.targetPlatform=1.6
+org.eclipse.jdt.core.compiler.codegen.unusedLocal=preserve
+org.eclipse.jdt.core.compiler.compliance=1.6
+org.eclipse.jdt.core.compiler.debug.lineNumber=generate
+org.eclipse.jdt.core.compiler.debug.localVariable=generate
+org.eclipse.jdt.core.compiler.debug.sourceFile=generate
+org.eclipse.jdt.core.compiler.problem.assertIdentifier=error
+org.eclipse.jdt.core.compiler.problem.enumIdentifier=error
+org.eclipse.jdt.core.compiler.source=1.6

Added: trunk/playground/abcl-test/lib/abcl.jar
==============================================================================
Binary file. No diff available.

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/filter_wrappers.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/filter_wrappers.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,192 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :filter-functions
+  (:use :base-tools :constants :tm-sparql)
+  (:import-from :cl progn handler-case let))
+
+
+(defun filter-functions::normalize-value (value)
+  "Returns the normalized value, i.e. if a literal
+   is passed as '12'^^xsd:integer 12 is returned."
+  (cond ((not (stringp value))
+	 value)
+	((or (base-tools:string-starts-with value "'")
+	     (base-tools:string-starts-with value "\""))
+	 (let* ((literal-result (tm-sparql::get-literal value))
+		(literal-value
+		 (cond ((or (base-tools:string-starts-with
+			     (getf literal-result :literal) "\"\"\"")
+			    (base-tools:string-starts-with
+			     (getf literal-result :literal) "'''"))
+			(subseq (getf literal-result :literal) 3
+				(- (length (getf literal-result :literal)) 3)))
+		       (t
+			(subseq (getf literal-result :literal) 1
+				(- (length (getf literal-result :literal)) 1)))))
+		(given-datatype
+		 (when (base-tools:string-starts-with
+			(getf literal-result :next-string) "^^")
+		   (subseq (getf literal-result :next-string) 2))))
+	   (tm-sparql::cast-literal literal-value given-datatype)))
+	(t
+	 value)))
+
+
+(defun filter-functions::not(x)
+  (not (filter-functions::normalize-value x)))
+
+
+(defun filter-functions::one+(x)
+  (1+ (filter-functions::normalize-value x)))
+
+
+(defun filter-functions::one-(x)
+  (1- (filter-functions::normalize-value x)))
+
+
+(defun filter-functions::+(x y)
+  (+ (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
+
+
+(defun filter-functions::-(x y)
+  (- (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
+
+
+(defun filter-functions::*(x y)
+  (* (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
+
+
+(defun filter-functions::/(x y)
+  (/ (filter-functions::normalize-value x)
+     (filter-functions::normalize-value y)))
+
+
+(defun filter-functions::or(x y)
+  (or (filter-functions::normalize-value x)
+      (filter-functions::normalize-value y)))
+
+
+(defun filter-functions::and(x y)
+  (and (filter-functions::normalize-value x)
+       (filter-functions::normalize-value y)))
+
+
+(defun filter-functions::=(x y)
+  (let ((local-x (filter-functions::normalize-value x))
+	(local-y (filter-functions::normalize-value y)))
+    (cond ((and (stringp local-x) (stringp local-y))
+	   (string= local-x local-y))
+	  ((and (numberp local-x)( numberp local-y))
+	   (= local-x local-y))
+	  (t
+	   (eql local-x local-y)))))
+
+
+(defun filter-functions::!=(x y)
+  (filter-functions::not
+   (filter-functions::= x y)))
+
+
+(defun filter-functions::<(x y)
+  (let ((local-x (filter-functions::normalize-value x))
+	(local-y (filter-functions::normalize-value y)))
+    (cond ((and (numberp local-x) (numberp local-y))
+	   (< local-x local-y))
+	  ((and (stringp local-x) (stringp local-y))
+	   (string< local-x local-y))
+	  ((and (typep local-x 'Boolean) (typep local-y 'Boolean))
+	   (and (not local-x) local-y))
+	  (t
+	   nil))))
+
+
+(defun filter-functions::>(x y)
+  (filter-functions::not
+   (filter-functions::< x y)))
+
+
+(defun filter-functions::<=(x y)
+  (filter-functions::or
+   (filter-functions::< x y)
+   (filter-functions::= x y)))
+
+
+(defun filter-functions::>=(x y)
+  (filter-functions::or
+   (filter-functions::> x y)
+   (filter-functions::= x y)))
+	   
+
+(defun filter-functions::regex(str pattern &optional flags)
+  (let* ((local-str (filter-functions::normalize-value str))
+	 (local-flags (filter-functions::normalize-value flags))
+	 (case-insensitive (when (find #\i local-flags) t))
+	 (multi-line (when (find #\m local-flags) t))
+	 (single-line (when (find #\s local-flags) t))
+	 (local-pattern
+	  (if (find #\x local-flags)
+	      (base-tools:string-replace
+	       (base-tools:string-replace
+		(base-tools:string-replace
+		 (base-tools:string-replace
+		  (filter-functions::normalize-value pattern)
+		  (string #\newline) "")
+		 (string #\tab) "") (string #\cr) "") " " "")
+	      (filter-functions::normalize-value pattern)))
+	 (scanner
+	  (ppcre:create-scanner local-pattern
+				:case-insensitive-mode case-insensitive
+				:multi-line-mode multi-line
+				:single-line-mode single-line)))
+    (ppcre:scan scanner local-str)))
+
+
+(defun filter-functions::bound(x)
+  (boundp x))
+
+
+(defun filter-functions::isLITERAL(x)
+  (or (numberp x)
+      (not (and (base-tools:string-starts-with x "<")
+		(base-tools:string-ends-with x ">")
+		(base-tools:absolute-uri-p x)))))
+
+
+(defun filter-functions::datatype(x)
+  (let ((type-suffix
+	 (when (and (stringp x)
+		    (or (base-tools:string-starts-with x "'")
+			(base-tools:string-starts-with x "\"")))
+	   (let* ((result (base-tools:get-literal x))
+		  (literal-datatype
+		   (when (base-tools:string-starts-with
+			  (getf result :next-string) "^^")
+		     (subseq (getf result :next-string) 2))))
+	     literal-datatype))))
+    (cond (type-suffix type-suffix)
+	  ((integerp x) constants::*xml-integer*)
+	  ((floatp x) constants::*xml-decimal*)
+	  ((numberp x) constants::*xml-double*)
+	  ((stringp x) constants::*xml-string*)
+	  (t (type-of x)))))
+
+
+(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

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,1221 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :TM-SPARQL
+  (:use :cl :datamodel :base-tools :exceptions :constants
+	:TM-SPARQL-Constants :xml-importer :xml-constants
+	:isidorus-threading :xml-tools)
+  (:export :SPARQL-Query
+	   :result
+	   :init-tm-sparql))
+
+
+
+(in-package :TM-SPARQL)
+
+(defvar *empty-label* "_empty_label_symbol" "A label symobl for empyt prefix labels")
+
+(defvar *equal-operators* nil "A Table taht contains tuples of 
+                               classes and equality operators.")
+
+
+
+(defgeneric sparql-node (construct &key revision)
+  (:documentation "Returns a string of the form <uri> or _t123 that represents
+                   a resource node or a blank node.")
+  (:method ((construct TopicMapConstructC) &key (revision d:*TM-REVISION*))
+    (declare (Integer revision))
+    (let ((uri-string (any-id construct :revision revision)))
+      (if uri-string
+	  (concat "<" uri-string ">")
+	  (let ((oid-string (write-to-string (elephant::oid construct)))
+		(pref (subseq (symbol-name (type-of construct)) 0 1)))
+	    (concat "_:" (string-downcase pref) oid-string))))))
+
+
+(defun init-tm-sparql (&optional (revision (get-revision)))
+  "Imports the file tmsparql_core_psis.xtm. core_psis.xtm has to be imported
+   before."
+  (with-writer-lock
+    (with-tm (revision "tmsparql.xtm" (concat *tms* "topic-map"))
+      (let ((core-dom (cxml:parse-file *tmsparql_core_psis.xtm*
+				       (cxml-dom:make-dom-builder)))
+	    (xtm-id (reverse
+		     (base-tools:string-until
+		      (reverse
+		       (pathname-name
+			xml-constants:*tmsparql_core_psis.xtm*)) "/"))))
+	(elephant:ensure-transaction (:txn-nosync t)
+	  (loop for top-elem across 
+	       (xpath-child-elems-by-qname (dom:document-element core-dom)
+					   *xtm2.0-ns* "topic")
+	     do (let ((top
+		       (from-topic-elem-to-stub top-elem revision
+						:xtm-id xtm-id)))
+		  (add-to-tm xml-importer::tm top))))))))
+
+
+
+(defun init-*equal-operators* ()
+  (setf *equal-operators*
+	(list (list :class 'Boolean :operator #'eql)
+	      (list :class 'String :operator #'string=)
+	      (list :class 'Number :operator #'=))))
+
+
+(init-*equal-operators*)
+
+
+(defun get-equal-operator (value)
+  (let ((entry
+	 (find-if #'(lambda(entry)
+		      (typep value (getf entry :class)))
+		  *equal-operators*)))
+    (when entry
+      (getf entry :operator))))
+
+
+(defclass SPARQL-Triple-Elem()
+  ((elem-type :initarg :elem-type
+	      :reader elem-type
+	      :type Symbol
+	      :initform (error
+			 (make-condition
+			  'missing-argument-error
+			  :message "From SPARQL-Triple-Elem(): elem-type must be set"))
+	      :documentation "Contains information about the type of this element
+                              possible values are 'IRI, 'VARIABLE, or 'LITERAL")
+   (value :initarg :value
+	  :accessor value
+	  :type T
+	  :initform nil
+	  :documentation "Contains the actual value of any type.")
+   (literal-lang :initarg :literal-lang
+		 :accessor literal-lang
+		 :initform nil
+		 :type String
+		 :documentation "Contains the @lang attribute of a literal")
+   (literal-datatype :initarg :literal-datatype
+		     :accessor literal-datatype
+		     :type String
+		     :initform nil
+		     :documentation "Contains the datatype of the literal,
+                                     e.g. xml:string"))
+  (:documentation "Represents one element of an RDF-triple."))
+
+
+(defclass SPARQL-Triple()
+  ((subject :initarg :subject
+	    :accessor subject
+	    :type SPARQL-Triple-Elem
+	    :initform (error
+		       (make-condition
+			'missing-argument-error
+			:message "From SPARQL-Triple(): subject must be set"))
+	    :documentation "Represents the subject of an RDF-triple.")
+   (subject-result :initarg :subject-result
+		   :accessor subject-result
+		   :type T
+		   :initform nil
+		   :documentation "Contains the result of the subject triple elem.")
+   (predicate :initarg :predicate
+	      :accessor predicate
+	      :type SPARQL-Triple-Elem
+	      :initform (error
+			 (make-condition
+			  'missing-argument-error
+			  :message "From SPARQL-Triple(): predicate must be set"))
+	    :documentation "Represents the predicate of an RDF-triple.")
+   (predicate-result :initarg :predicate-result
+		     :accessor predicate-result
+		     :type T
+		     :initform nil
+		     :documentation "Contains the result of the predicate
+                                     triple elem.")
+   (object :initarg :object
+	   :accessor object
+	   :type SPARQL-Triple-Elem
+	   :initform (error
+		      (make-condition
+		       'missing-argument-error
+		       :message "From SPARQL-Triple-(): object must be set"))
+	   :documentation "Represents the subject of an RDF-triple.")
+   (object-result :initarg :object-result
+		  :accessor object-result
+		  :type T
+		  :initform nil
+		  :documentation "Contains the result of the object triple elem."))
+  (:documentation "Represents an entire RDF-triple."))
+
+
+(defclass SPARQL-Query ()
+  ((revision :initarg :revision
+	     :accessor revision
+	     :type Integer
+	     :initform 0
+	     :documentation "Represents the revision in which all the queries
+                             are processed in the DB.")
+   (original-query :initarg :query
+		   :accessor original-query  ;this value is only for internal
+					     ;purposes and mustn't be reset
+		   :type String
+		   :initform (error
+			      (make-condition
+			       'missing-argument-error
+			       :message "From TM-Query(): original-query must be set"))
+		   :documentation "Containst the original received querry as string")
+   (variables :initarg :variables
+	      :accessor variables ;this value is only for internal purposes
+					;purposes and mustn't be reset
+	      :type List
+	      :initform nil
+	      :documentation "A list of that contains the variable
+                              names as strings.")
+   (prefixes :initarg :prefixes
+	     :accessor prefixes ;this value is only for internal purposes
+			        ;purposes and mustn't be reset
+	     :type List
+	     :initform nil
+	     :documentation "A list of the form
+                            ((:label 'id' :value 'prefix'))")
+   (base-value :initarg :base ;initialy the requester's address
+	       :accessor base-value ;this value is only for internal purposes
+				    ;purposes and mustn't be reset
+	       :type String
+	       :initform nil
+	       :documentation "Contains the last set base-value.")
+   (select-group :initarg :select-group
+		 :accessor select-group ;this value is only for
+					;internal purposes purposes
+					;and mustn't be reset
+		 :type List
+		 :initform nil
+		 :documentation "Contains a SPARQL-Group that represents
+                                 the entire inner select-where statement.")
+   (filters :initarg filters
+	    :accessor filters ;this value is only for internal purposes
+			      ;purposes and mustn't be reset
+	    :type List ;a list of strings
+	    :initform nil
+	    :documentation "Contains strings, each string represents a filter
+                            that was transformed to lisp code and can be evoked
+                            on each triple in the list select-group."))
+  (:documentation "This class represents the entire request."))
+
+
+(defgeneric *-p (construct)
+  (:documentation "Returns t if the user selected all variables with *.")
+  (:method ((construct SPARQL-Query))
+    (loop for var in (variables construct)
+       when (string= var "*")
+       return t)))
+
+
+(defgeneric add-filter (construct filter)
+  (:documentation "Pushes the filter string to the corresponding list in
+                   the construct.")
+  (:method ((construct SPARQL-Query) (filter String))
+    (push filter (filters construct))))
+
+
+(defmethod variables ((construct SPARQL-Triple))
+  "Returns all variable names that are contained in the passed element."
+  (remove-duplicates
+   (remove-null
+    (list (when (variable-p (subject construct))
+	    (value (subject construct)))
+	  (when (variable-p (predicate construct))
+	    (value (predicate construct)))
+	  (when (variable-p (object construct))
+	    (value (object construct)))))
+   :test #'string=))
+
+
+(defgeneric add-triple (construct triple)
+  (:documentation "Adds a triple object to the select-group list.")
+  (:method ((construct SPARQL-Query) (triple SPARQL-Triple))
+    (push triple (slot-value construct 'select-group))))
+
+
+(defgeneric (setf elem-type) (construct elem-type)
+  (: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)))
+      (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)))
+
+
+(defgeneric add-prefix (construct prefix-label prefix-value)
+  (:documentation "Adds the new prefix tuple to the list of all existing.
+                   If there already exists a tuple with the same label
+                   the label's value will be overwritten by the new value.")
+  (:method ((construct SPARQL-Query) (prefix-label String) (prefix-value String))
+    (let ((existing-tuple
+	   (find-if #'(lambda(x)
+			(string= (getf x :label) prefix-label))
+		    (prefixes construct))))
+      (if existing-tuple
+	  (setf (getf existing-tuple :value) prefix-value)
+	  (push (list :label prefix-label :value prefix-value)
+		(prefixes construct))))))
+
+
+(defgeneric get-prefix (construct string-with-prefix)
+  (:documentation "Returns the URL corresponding to the found prefix-label
+                   followed by : and the variable. Otherwise the return
+                   value is nil.")
+  (:method ((construct SPARQL-query) (string-with-prefix String))
+    (loop for entry in (prefixes construct)
+       when (string-starts-with string-with-prefix (concat (getf entry :label) ":"))
+       return (concatenate-uri
+	       (getf entry :value)
+	       (string-after string-with-prefix (concat (getf entry :label) ":"))))))
+
+
+(defgeneric add-variable (construct variable-name)
+  (:documentation "Adds a new variable-name with its value to the aexisting list.
+                   If a variable-already exists the existing entry will be
+                   overwritten. An entry is of the form
+                   (:variable string :value any-type).")
+  (:method ((construct SPARQL-Query) (variable-name String))
+    (unless (find variable-name (variables construct) :test #'string=)
+      (push variable-name (variables construct)))))
+
+
+(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
+                   is evaluated, since all occurrences have the same values,
+                   because reduce-results is called before and makes an
+                   intersection over all triples.")
+  (:method ((construct SPARQL-Query) (variable-name String) (existing-results List))
+    (let* ((found-p nil)
+	   (results
+	    (loop for triple in (select-group construct)
+	       when (and (variable-p (subject triple))
+			 (string= (value (subject triple)) variable-name))
+	       return (progn (setf found-p t)
+			     (subject-result triple))
+	       when (and (variable-p (predicate triple))
+			 (string= (value (predicate triple)) variable-name))
+	       return (progn (setf found-p t)
+			     (predicate-result triple))
+	       when (and (variable-p (object triple))
+			 (string= (value (object triple))
+				  variable-name))
+	       return (progn (setf found-p t)
+			     (object-result triple))))
+	   (new-results nil))
+      (if (not found-p)
+	  existing-results
+	  (if existing-results
+	      (dolist (result results new-results)
+		(dolist (old-result existing-results)
+		  (push (append old-result (list (list :variable-name variable-name
+						       :variable-value result)))
+			new-results)))
+	      (map 'list #'(lambda(result)
+			     (list (list :variable-name variable-name
+					 :variable-value result)))
+		   results))))))
+
+
+(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 "(let* ((true t)(false nil)"))
+    (dolist (var-elem variable-values)
+      (push-string (concat "(?" (getf var-elem :variable-name) " "
+			   (write-to-string (getf var-elem :variable-value)) ")")
+		   result)
+      (push-string (concat "($" (getf var-elem :variable-name) " "
+			   (write-to-string (getf var-elem :variable-value)) ")")
+		   result))
+    (push-string (concat "(result " filter "))") result)
+    (push-string "(declare (Ignorable true false " result)
+    (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)" result)
+    (concat "(handler-case " result " (condition () nil))")))
+
+
+(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))
+
+
+(defun variable-list= (x y)
+  (and (string= (getf x :variable-name)
+		(getf y :variable-name))
+       (literal= (getf x :variable-value)
+		 (getf y :variable-value))))
+
+
+(defgeneric process-filters (construct)
+  (:documentation "Processes all filters by calling invoke-filter.")
+  (:method ((construct SPARQL-Query))
+    (dolist (filter (filters construct))
+      (let* ((filter-variable-names
+	      (get-variables-from-filter-string filter))
+	     (filter-variable-values nil)
+	     (true-values nil))
+	(dolist (var-name filter-variable-names)
+	  (setf filter-variable-values
+		(make-variable-values construct var-name filter-variable-values)))
+	(dolist (filter (filters construct))
+	  (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))
+
+
+(defgeneric idx-of (construct variable-name variable-value &key what)
+  (:documentation "Returns the idx of the variable with the name
+                   variable-name and the value variable-value.")
+  (:method ((construct SPARQL-Triple) (variable-name String)
+	    variable-value &key (what :subject))
+    (declare (Keyword what))
+    (let ((result nil)
+	  (local-results
+	   (cond ((eql what :subject) (subject-result construct))
+		 ((eql what :predicate) (predicate-result construct))
+		 ((eql what :object) (object-result construct))))
+	  (is-variable
+	   (cond ((eql what :subject)
+		  (and (variable-p (subject construct))
+		       (value (subject construct))))
+		 ((eql what :predicate)
+		  (and (variable-p (predicate construct))
+		       (value (predicate construct))))
+		 ((eql what :object)
+		  (and (variable-p (object construct))
+		       (value (object construct)))))))
+      (when is-variable
+	(remove-null
+	 (dotimes (idx (length local-results))
+	   (when (literal= variable-value (elt local-results idx))
+	     (push idx result)))))
+      result)))
+
+
+(defgeneric delete-rows-by-value (construct variable-name value-to-delete)
+  (:documentation "Deletes all rows that owns a variable with the
+                   given value.")
+  (:method ((construct SPARQL-Query) (variable-name String) value-to-delete)
+    (dolist (triple (select-group construct))
+      (let* ((subj-delete-idx-lst
+	      (idx-of triple variable-name value-to-delete))
+	     (pred-delete-idx-lst
+	      (idx-of triple variable-name value-to-delete :what :predicate))
+	     (obj-delete-idx-lst
+	      (idx-of triple variable-name value-to-delete :what :object))
+	     (all-idxs (union (union subj-delete-idx-lst
+				     pred-delete-idx-lst)
+			      obj-delete-idx-lst)))
+	(when all-idxs
+	  (let ((new-values nil))
+	    (dotimes (idx (length (subject-result triple)))
+	      (when (not (find idx all-idxs))
+		(push
+		 (list :subject (elt (subject-result triple) idx)
+		       :predicate (elt (predicate-result triple) idx)
+		       :object (elt (object-result 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))))))
+    construct))
+
+
+(defgeneric set-results (construct &key revision)
+  (:documentation "Calculates the result of a triple and set all the values in
+                   the passed object.")
+  (:method ((construct SPARQL-Triple) &key (revision d:*TM-REVISION*))
+    (declare (Integer revision))
+    (set-tm-constructs construct :revision revision)
+    (when (not (iri-not-found-p construct)) ;there is only a result if all IRIs were found
+      (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-special-uris construct :revision revision))))
+	(map 'list #'(lambda(result)
+		       (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, ...
+	     results)))))
+
+
+(defgeneric filter-by-given-object (construct &key revision)
+  (:documentation "Returns a list representing a triple that is the result
+                   of a given object.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (when (and (not (variable-p (object construct)))
+	       (variable-p (predicate construct))
+	       (variable-p (subject construct)))
+      (cond ((literal-p (object construct))
+	     (filter-by-characteristic-value (value (object construct))
+					     (literal-datatype (object construct))
+					     :revision revision))
+	    ((iri-p (object construct))
+	     (filter-by-otherplayer (value (object construct))
+				    :revision revision))))))
+
+
+(defun return-characteristics (literal-value literal-datatype)
+  "Returns all characteristica that own the specified value."
+  (declare (String literal-datatype))
+  (let ((chars
+	 (cond ((string= literal-datatype *xml-string*)
+		(remove-if #'(lambda(elem)
+			       (string/= (charvalue elem) literal-value))
+			   (append
+			    (elephant:get-instances-by-value
+			     'OccurrenceC 'charvalue literal-value)
+			    (elephant:get-instances-by-value
+			     'VariantC 'charvalue literal-value)
+			    (elephant:get-instances-by-value
+			     'NameC 'charvalue literal-value))))
+	       ((and (string= literal-datatype *xml-boolean*)
+		     literal-value)
+		(remove-if #'(lambda(elem)
+			       (string/= (charvalue elem) "true"))
+			   (append (elephant:get-instances-by-value
+				    'VariantC 'charvalue "true")
+				   (elephant:get-instances-by-value
+				    'OccurrenceC 'charvalue "true"))))
+	       ((and (string= literal-datatype *xml-boolean*)
+		     (not literal-value))
+		(remove-if #'(lambda(elem)
+			       (string/= (charvalue elem) "false"))
+			   (append (elephant:get-instances-by-value
+				    'VariantC 'charvalue "true")
+				   (elephant:get-instances-by-value
+				    'OccurrenceC 'charvalue "false"))))
+	       ((or (string= literal-datatype *xml-double*)
+		    (string= literal-datatype *xml-decimal*)
+		    (string= literal-datatype *xml-integer*))
+		(let ((constructs
+		       (remove-if #'(lambda(con)
+				      (string/= (datatype con) literal-datatype))
+				  (append
+				   (elephant:get-instances-by-value
+				    'VariantC 'datatype literal-datatype)
+				   (elephant:get-instances-by-value
+				    'OccurrenceC 'datatype literal-datatype)))))
+		  (remove-if #'(lambda(con)
+				 (not (literal= (charvalue con) literal-value)))
+			     constructs))))))
+    ;;elephant returns names, occurences, and variants if any string
+    ;;value matches, so all duplicates have to be removed
+    (remove-duplicates chars)))
+
+
+(defun filter-by-characteristic-value (literal-value literal-datatype
+				       &key (revision *TM-REVISION*))
+  "Returns a triple where the passed value is a charvalue in a occurrence
+   or name. The subject is the owner topic and the predicate is the
+   characteristic's type.
+   (Variants are not considered because they are not typed, so they cannot
+   be referenced via a predicate)."
+  (declare (Integer revision)
+	   (String literal-datatype))
+    (remove-null
+     (map 'list #'(lambda(char)
+		    (let ((subj-uri
+			   (when-do top (parent char :revision revision)
+				    (sparql-node top :revision revision)))
+			  (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)))
+	  (remove-if #'(lambda(char)
+			 (typep char 'VariantC))
+		     (return-characteristics literal-value literal-datatype)))))
+
+
+(defgeneric filter-by-otherplayer (construct &key revision)
+  (:documentation "Returns triples where the passed player is the object,
+                   the other player is the subject and the type of the passed
+                   player's role is the predicate.")
+  (:method ((construct TopicC) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (let ((roles-by-oplayer (player-in-roles construct :revision revision))
+	  (obj-uri (sparql-node construct :revision revision)))
+      (remove-null
+       (map 'list
+	    #'(lambda(role)
+		(let ((orole
+		       (when-do assoc (parent role :revision revision)
+				(when (= (length (roles assoc :revision revision))
+					 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)))
+	    roles-by-oplayer)))))
+
+
+(defgeneric filter-by-given-predicate (construct &key revision)
+  (:documentation "Returns all topics that owns a characteristic of the
+                   given type or an associaiton with an otherrole of the
+                   given type. The result is a plist representing a triple.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (when (and (variable-p (subject construct))
+	       (iri-p (predicate construct)))
+      (cond ((variable-p (object construct))
+	     (append (filter-by-otherroletype construct :revision revision)
+		     (filter-by-characteristictype construct :revision revision)))
+	    ((literal-p (object construct))
+	     (filter-by-characteristictype construct :revision revision))
+	    ((iri-p (object construct))
+	     (filter-by-otherroletype construct :revision revision))))))
+
+
+(defgeneric filter-by-otherroletype (construct &key revision)
+  (:documentation "Returns triple where the passed predicate is a
+                   type of a role. The returned subject is the otherplayer,
+                   the predicate is the passed predicate, the object is
+                   the player of the role of the passed type.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (when (or (variable-p (object construct))
+	      (iri-p (object construct)))
+      (let* ((roles-by-type
+	      (remove-null
+	       (map 'list #'(lambda(typed-construct)
+			      (when (typep typed-construct 'RoleC)
+				typed-construct))
+		    (used-as-type (value (predicate construct)) :revision revision))))
+	     (roles-by-player
+	      (if (iri-p (object construct))
+		  (remove-null
+		   (map 'list #'(lambda(role)
+				  (when (eql (player role :revision revision)
+					     (value (object construct)))
+				    role))
+			roles-by-type))
+		  roles-by-type)))
+	(remove-null
+	 (map 'list
+	      #'(lambda(role)
+		  (let* ((assoc (parent role :revision revision))
+			 (orole (when (and assoc
+					   (= (length
+					       (roles assoc :revision revision))
+					      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
+			  (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))))))
+
+
+(defgeneric filter-by-characteristictype (construct &key revision)
+  (:documentation "Returns the results of filter-by-nametype and
+                   filter-by-occurrencetype.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (append (filter-by-nametype construct :revision revision)
+	    (filter-by-occurrencetype construct :revision revision))))
+
+
+(defgeneric filter-by-nametype (construct &key revision)
+  (:documentation "Returns all names that corresponds to the given parameters.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (when (and (not (iri-p (object construct)))
+	       (or (not (literal-datatype (object construct)))
+		   (string= (literal-datatype (object construct)) *xml-string*)))
+      (let* ((names-by-type
+	      (remove-null
+	       (map 'list #'(lambda(typed-construct)
+			      (when (typep typed-construct 'NameC)
+				typed-construct))
+		    (used-as-type (value (predicate construct))
+				  :revision revision))))
+	     (names-by-literal
+	      (if (variable-p (object construct))
+		  names-by-type
+		  (remove-null
+		   (map 'list #'(lambda(name)
+				  (when (string= (charvalue name)
+						 (value (object construct)))
+				    name))
+			names-by-type)))))
+	(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*))
+	      names-by-literal))))))
+
+
+(defgeneric filter-by-occurrencetype (construct &key revision)
+  (:documentation "Returns all occurrence that corresponds to the
+                   given parameters.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (unless (iri-p (object construct))
+      (let* ((occs-by-type
+	      (remove-null
+	       (map 'list #'(lambda(typed-construct)
+			      (when (typep typed-construct 'OccurrenceC)
+				typed-construct))
+		    (used-as-type (value (predicate construct))
+				  :revision revision))))
+	     (all-occs
+	      (let ((literal-value (if (variable-p (object construct))
+				       nil
+				       (value (object construct))))
+		    (literal-datatype (literal-datatype (object construct))))
+		(remove-null
+		 (map 'list #'(lambda(occ)
+				(filter-occ-by-value occ literal-value
+						     literal-datatype))
+		      occs-by-type)))))
+	(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)))
+	      all-occs))))))
+
+
+(defgeneric filter-by-given-subject (construct &key revision)
+  (:documentation "Calls filter-characteristics and filter associations
+                   for the topic that is set as a subject of the passed triple.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (when (iri-p (subject construct))
+      (let* ((subj (value (subject construct)))
+	     (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)))
+	      ((literal-p (object construct))
+	       (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)))))))
+
+
+(defgeneric literal-p (construct)
+  (:documentation "Returns t if the passed construct has an elem-type
+                   set to 'LITERAL.")
+  (:method ((construct SPARQL-Triple-Elem))
+    (eql (elem-type construct) 'LITERAL)))
+
+
+(defgeneric iri-p (construct)
+  (:documentation "Returns t if the passed construct has an elem-type
+                   set to 'IRI.")
+  (:method ((construct SPARQL-Triple-Elem))
+    (eql (elem-type construct) 'IRI)))
+
+
+(defgeneric variable-p (construct)
+  (:documentation "Returns t if the passed construct has an elem-type
+                   set to 'VARIABLE.")
+  (:method ((construct SPARQL-Triple-Elem))
+    (eql (elem-type construct) 'VARIABLE)))
+
+
+(defgeneric iri-not-found-p (construct)
+  (:documentation "Must be called after a call of set-tm-constructs.
+                   It returns t if a TM-construct was not found for a
+                   given IRI, so the result value of a query is nil.")
+  (:method ((construct SPARQL-Triple))
+    (or (iri-not-found-p (subject construct))
+	(iri-not-found-p (predicate construct))
+	(iri-not-found-p (object construct)))))
+
+
+(defmethod iri-not-found-p ((construct SPARQL-Triple-Elem))
+  (and (eql (elem-type construct) 'IRI)
+       (not (value construct))))
+
+
+(defgeneric set-tm-constructs (construct &key revision)
+  (:documentation "Calls the method set-tm-construct for every element
+                   in a SPARQL-Triple object.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (when-do subj (subject construct)
+	     (set-tm-construct subj :revision revision))
+    (when-do pred (predicate construct)
+	     (set-tm-construct pred :revision revision))
+    (when-do obj (object construct) (set-tm-construct obj :revision revision))))
+
+
+(defgeneric set-tm-construct (construct &key revision)
+  (:documentation "Replaces the IRI in the given object by the corresponding
+                   TM-construct.")
+  (:method ((construct SPARQL-Triple-Elem) &key (revision *TM-REVISION*))
+    (declare (Integer revision))
+    (when (eql (elem-type construct) 'IRI)
+      (setf (value construct)
+	    (get-item-by-any-id (value construct) :revision revision)))))
+
+
+(defun literal= (value-1 value-2)
+  "Returns t if both arguments are equal. The equality function is searched in
+   the table *equal-operators*."
+  (when (or (and (numberp value-1) (numberp value-2))
+	    (typep value-1 (type-of value-2))
+	    (typep value-2 (type-of value-1)))
+    (let ((operator (get-equal-operator value-1)))
+      (funcall operator value-1 value-2))))
+
+
+(defun filter-datatypable-by-value (construct literal-value literal-datatype)
+  "A helper that compares the datatypable's charvalue with the passed
+   literal value."
+  (declare (d::DatatypableC construct)
+	   (type (or Null String) literal-value literal-datatype))
+  (when (or (not literal-datatype)
+	    (string= (datatype construct) literal-datatype))
+    (if (not literal-value)
+	construct
+	(handler-case
+	    (let ((occ-value (cast-literal (charvalue construct)
+					   (datatype construct))))
+	      (when (literal= occ-value literal-value)
+		construct))
+	  (condition () nil)))))	      
+
+
+(defun filter-variant-by-value (variant literal-value literal-datatype)
+  "A helper that compares the occurrence's variant's with the passed
+   literal value."
+  (declare (VariantC variant)
+	   (type (or Null String) literal-value literal-datatype))
+  (filter-datatypable-by-value variant literal-value literal-datatype))
+
+
+(defun filter-occ-by-value (occurrence literal-value literal-datatype)
+  "A helper that compares the occurrence's charvalue with the passed
+   literal value."
+  (declare (OccurrenceC occurrence)
+	   (type (or Null String) literal-value literal-datatype))
+  (filter-datatypable-by-value occurrence literal-value literal-datatype))
+      
+
+(defgeneric filter-occurrences(construct type-top literal-value
+					 literal-datatype &key revision)
+  (:documentation "Returns a list representing a triple.")
+  (:method ((construct TopicC) type-top literal-value literal-datatype
+	    &key (revision *TM-REVISION*))
+    (declare (Integer revision)
+	     (type (or Null String) literal-value literal-datatype)
+	     (type (or Null TopicC) type-top))
+    (let* ((occs-by-type
+	    (if type-top
+		(occurrences-by-type construct type-top :revision revision)
+		(occurrences construct :revision revision)))
+	   (all-occs
+	    (remove-null
+	     (map 'list
+		  #'(lambda(occ)
+		      (filter-occ-by-value occ literal-value literal-datatype))
+		  occs-by-type)))
+	   (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)))
+	    all-occs)))))
+
+
+(defgeneric filter-names(construct type-top literal-value
+				   &key revision)
+  (:documentation "Returns a list representing a triple.")
+  (:method ((construct TopicC) type-top literal-value
+	    &key (revision *TM-REVISION*))
+    (declare (Integer revision)
+	     (type (or Null String) literal-value)
+	     (type (or Null TopicC) type-top))
+    (let* ((by-type
+	    (if type-top
+		(names-by-type construct type-top :revision revision)
+		(names construct :revision revision)))
+	   (by-literal (if literal-value
+			   (names-by-value
+			    construct #'(lambda(name)
+					  (string= name literal-value))
+			    :revision revision)
+			   (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)))))
+
+
+(defgeneric filter-characteristics (construct type-top literal-value
+					      literal-datatype &key revision)
+  (:documentation "Returns a list representing a triple.")
+  (:method ((construct TopicC) type-top literal-value literal-datatype
+	    &key (revision *TM-REVISION*))
+    (declare (Integer revision)
+	     (type (or Null String) literal-value literal-datatype)
+	     (type (or Null TopicC) type-top))
+    (let ((occs (filter-occurrences construct type-top literal-value
+				    literal-datatype :revision revision))
+	  (names (if (or (not literal-datatype)
+			 (string= literal-datatype *xml-string*))
+		     (filter-names construct type-top literal-value
+				   :revision revision)
+		     nil)))
+      (append occs names))))
+
+
+(defgeneric filter-associations(construct type-top player-top
+					  &key revision)
+  (:documentation "Returns a list of the form (:predicate <uri>
+                   :object <uri> :subject <uri>).
+                   predicate is the type of the otherrole and
+                   object is the uri of the otherplayer.")
+  (:method ((construct TopicC) type-top player-top
+	    &key (revision *TM-REVISION*))
+    (declare (Integer revision)
+	     (type (or Null TopicC) type-top player-top))
+    (let ((assocs
+	   (associations-of construct nil nil type-top player-top
+			    :revision revision))
+	  (subj-uri (sparql-node construct :revision revision)))
+      (remove-null ;only assocs with two roles can match!
+       (map 'list
+	    #'(lambda(assoc)
+		(when (= (length (roles assoc :revision revision)) 2)
+		  (let* ((other-role
+			  (find-if #'(lambda(role)
+				       (and
+					(not (eql construct
+						  (player role :revision revision)))
+					(or (not type-top)
+					    (eql type-top
+						 (instance-of
+						  role :revision revision)))))
+				   (roles assoc :revision revision)))
+			 (pred-uri
+			  (when other-role
+			    (when-do
+			     type-top (instance-of other-role
+						   :revision revision)
+			     (sparql-node type-top :revision revision))))
+			 
+			 (obj-uri
+			  (when other-role
+			    (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))))
+	    assocs)))))
+
+
+(defgeneric result (construct)
+  (:documentation "Returns the result of the entire query.")
+  (:method ((construct SPARQL-Query))
+    (let* ((response-variables
+	    (reverse (if (*-p construct)
+			 (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
+							  cleaned-results)))
+	   response-variables))))
+
+
+(defgeneric make-result-lists (construct)
+  (:documentation "Returns a list of the form ((:variable 'var-name'
+                   :result (<any-object>)).")
+  (:method ((construct SPARQL-Query))
+    (remove-null
+     (loop for triple in (select-group construct)
+	append (remove-null
+		(list
+		 (when (variable-p (subject triple))
+		   (list :variable (value (subject triple))
+			 :result (subject-result triple)))
+		 (when (variable-p (predicate triple))
+		   (list :variable (value (predicate triple))
+			  :result (predicate-result triple)))
+		 (when (variable-p (object triple))
+		   (list :variable (value (object triple))
+			 :result (object-result triple)))))))))
+
+
+(defgeneric all-variables (result-lists)
+  (:documentation "Returns a list of all variables that are contained in
+                   the passed result-lists."))
+
+
+(defmethod all-variables ((result-lists List))
+  (remove-duplicates
+   (map 'list #'(lambda(entry)
+		  (getf entry :variable))
+	result-lists)
+   :test #'string=))
+
+
+(defmethod all-variables ((construct SPARQL-Query))
+  "Returns all variables that are contained in the select group memebers."
+  (remove-duplicates
+   (remove-null
+    (loop for triple in (select-group construct)
+       append (variables triple)))
+   :test #'string=))
+
+
+(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.")
+  (:method ((variable-name String) (result-lists List))
+    (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)
+		       (second all-values)
+		       list-1))
+	   (more-lists (rest (rest all-values))))
+      (recursive-intersection list-1 list-2 more-lists))))
+
+
+(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))))))
+    (if (not more-lists)
+	current-result
+	(recursive-intersection current-result (first more-lists)
+				(rest more-lists)))))
+
+
+(defgeneric reduce-results(construct result-lists)
+  (:documentation "Reduces the select-group of the passed construct by processing
+                   all triples with the intersection-results.")
+  (:method ((construct SPARQL-Query) (result-lists List))
+    (map 'list #'(lambda(triple)
+		   (reduce-triple triple result-lists))
+	 (select-group construct))))
+
+
+(defgeneric reduce-triple(construct result-lists)
+  (:documentation "Reduces the results of a triple by using only the
+                   intersection values.")
+  (: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)))
+		 triple-variables)))
+      (map 'list #'(lambda(entry)
+		     (delete-rows construct (getf entry :variable)
+				  (getf entry :result)))
+	   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
+                   row that is not contained in the dont-touch-values.")
+  (:method ((construct SPARQL-Triple) (variable-name String)
+	    (dont-touch-values List))
+    (let ((var-elem
+	   (cond ((and (variable-p (subject construct))
+		       (string= (value (subject construct)) variable-name))
+		  (subject-result construct))
+		 ((and (variable-p (predicate construct))
+		       (string= (value (predicate construct)) variable-name))
+		  (predicate-result construct))
+		 ((and (variable-p (object construct))
+		       (string= (value (object construct)) variable-name))
+		  (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)))
+	       (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)))
+		     rows-to-hold)))
+	  (setf (subject-result construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :subject)) new-result-list))
+	  (setf (predicate-result construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :predicate)) new-result-list))
+	  (setf (object-result construct)
+		(map 'list #'(lambda(entry)
+			       (getf entry :object)) new-result-list)))))))
+
+
+(defgeneric results-for-variable (variable-name result-lists)
+  (:documentation "Returns a list with result-lists for the passed variable.")
+  (:method ((variable-name String) (result-lists List))
+    (let* ((cleaned-result-lists
+	    (remove-if-not #'(lambda(entry)
+			       (string= (getf entry :variable)
+					variable-name))
+			   result-lists))
+	   (values
+	    (map 'list #'(lambda(entry)
+			   (getf entry :result))
+		 cleaned-result-lists)))
+      values)))
+
+
+(defun cast-literal (literal-value literal-type)
+  "A helper function that casts the passed string value of the literal
+   corresponding to the passed literal-type."
+  (declare (String literal-value literal-type))
+  (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))
+	((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))
+	(t ; return the value as a string
+	 literal-value)))
+
+
+(defmethod initialize-instance :after ((construct SPARQL-Query) &rest args)
+  (declare (ignorable args))
+  (parser-start construct (original-query construct))
+  (dolist (triple (select-group construct))
+    (set-results triple :revision (revision construct)))
+  ;; filters all entries that are not important for the result
+  ;; => an intersection is invoked
+  (reduce-results construct (make-result-lists construct))
+  (process-filters construct)
+  construct)
\ No newline at end of file

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_constants.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_constants.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,35 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :TM-SPARQL-Constants
+  (:use :cl :base-tools)
+  (:nicknames tms)
+  (:export :*tms*
+	   :*tms-reifier*
+	   :*tms-role*
+	   :*tms-player*
+	   :*tms-topicProperty*
+	   :*tms-scope*
+	   :*tms-value*))
+
+(in-package :TM-SPARQL-Constants)
+
+(defvar *tms* "http://www.networkedplanet.com/tmsparql/")
+
+(defvar *tms-reifier* (concat *tms* "reifier"))
+
+(defvar *tms-role* (concat *tms* "role"))
+
+(defvar *tms-player* (concat *tms* "player"))
+
+(defvar *tms-topicProperty* (concat *tms* "topicProperty"))
+
+(defvar *tms-scope* (concat *tms* "scope"))
+
+(defvar *tms-value* (concat *tms* "value"))
\ No newline at end of file

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_filter.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,975 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :TM-SPARQL)
+
+
+(defparameter *supported-functions*
+  (list "BOUND" "isLITERAL" "STR" "DATATYPE" "REGEX")
+  "Contains all supported SPARQL-functions")
+
+
+(defparameter *supported-primary-arithmetic-operators*
+  (list "*" "/") "Contains all supported arithmetic operators.")
+
+
+(defparameter *supported-secundary-arithmetic-operators*
+  (list "+" "-") "Contains all supported arithmetic operators.")
+
+
+(defparameter *supported-compare-operators*
+  (list "!=" "<=" ">=" "=" "<" ">") ;note the order is important!
+                                    ;the operators with length = 2
+                                    ;must be listed first
+  "Contains all supported binary operators.")
+
+
+(defparameter *supported-join-operators*
+  (list "||" "&&") "Contains all supported join operators.")
+
+
+(defparameter *supported-unary-operators*
+  (list "!" "+" "-") "Contains all supported unary operators")
+
+
+(defparameter *allowed-filter-calls*
+  (append (list "one+" "one-" "progn" "or" "and" "not" "/=" "="
+		">" ">=" "<" "<=" "+" "-" "*" "/")
+	  *supported-functions*))
+
+
+(defun *2-compare-operators* ()
+  (remove-null
+   (map 'list #'(lambda(op)
+		  (when (= (length op) 2)
+		    op))
+	*supported-compare-operators*)))
+
+
+(defun *1-compare-operators* ()
+  (remove-null
+   (map 'list #'(lambda(op)
+		  (when (= (length op) 1)
+		    op))
+	*supported-compare-operators*)))
+
+
+(defun *supported-arithmetic-operators* ()
+  (append *supported-primary-arithmetic-operators*
+	  *supported-secundary-arithmetic-operators*))
+
+
+(defun *supported-binary-operators* ()
+  (append (*supported-arithmetic-operators*)
+	  *supported-compare-operators*
+	  *supported-join-operators*))
+
+
+(defun *supported-operators* ()
+  (union (*supported-binary-operators*) *supported-unary-operators*
+	 :test #'string=))
+
+
+(defparameter *supported-brackets*
+  (list "(" ")")
+  "Contains all supported brackets in a list of strings.")
+
+
+(defun make-sparql-parser-condition(rest-of-query entire-query expected)
+  "Creates a spqrql-parser-error object."
+  (declare (String rest-of-query entire-query expected))
+  (let ((message
+	 (format nil "The query:~%\"~a\"~%~%has a bad token at position ~a => ~a.~%Expected: ~a"
+		 entire-query (- (length entire-query)
+				 (length rest-of-query))
+		 (subseq entire-query (- (length entire-query)
+					 (length rest-of-query)))
+		 expected)))
+    (make-condition 'sparql-parser-error :message message)))
+
+
+(defgeneric parse-filter (construct query-string)
+  (:documentation "A helper functions that returns a filter and the next-query
+                   string in the form (:next-query string
+                   :filter-string object).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    ;note the order of the invacations is important!
+    (let* ((result-set-boundings (set-boundings construct query-string))
+	   (filter-string (getf result-set-boundings :filter-string))
+	   (next-query (getf result-set-boundings :next-query))
+	   (original-filter-string
+	    (subseq query-string 0 (- (length query-string)
+				      (length next-query))))
+	   (filter-string-unary-ops
+	    (set-unary-operators construct filter-string))
+	   (filter-string-or-and-ops
+	    (set-or-and-operators construct filter-string-unary-ops
+				  original-filter-string))
+	   (filter-string-arithmetic-ops
+	    (set-arithmetic-operators construct filter-string-or-and-ops))
+	   (filter-string-compare-ops
+	    (set-compare-operators construct filter-string-arithmetic-ops))
+	   (filter-string-functions
+	    (set-functions construct filter-string-compare-ops)))
+      (add-filter construct
+		  (scan-filter-for-deprecated-calls
+		   construct filter-string-functions original-filter-string))
+      (parse-group construct next-query))))
+
+
+(defgeneric scan-filter-for-deprecated-calls (construct filter-string
+							original-filter)
+  (:documentation "Returns the passed filter-string where all functions
+                   are explicit wrapped in the filter-functions package
+                   or throws a sparql-parser-error of there is an
+                   unallowed function call.")
+  (:method ((construct SPARQL-Query) (filter-string String)
+	    (original-filter String))
+    (let ((result ""))
+      (dotimes (idx (length filter-string) result)
+	(let ((fun-name (return-function-name (subseq filter-string idx))))
+	  (cond ((not fun-name)
+		 (push-string (subseq filter-string idx (1+ idx)) result))
+		((string-starts-with-one-of fun-name *allowed-filter-calls*)
+		 (push-string "(filter-functions::" result)
+		 (push-string fun-name result)
+		 (incf idx (length fun-name)))
+		(t
+		 (error 
+		  (make-condition
+		   'exceptions:sparql-parser-error
+		   :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the deprecated function ~a!"
+				    filter-string original-filter fun-name))))))))))
+
+
+(defun return-function-name (filter-string)
+  "If the string starts with ( there is returned the function name
+   that is placed directly after the (."
+  (declare (String filter-string))
+  (when (string-starts-with filter-string "(")
+    (let ((local-str (trim-whitespace-left (subseq filter-string 1)))
+	  (whitespaces (map 'list #'string (white-space)))
+	  (result ""))
+      (dotimes (idx (length local-str) result)
+	(let ((current-char (subseq local-str idx (1+ idx))))
+	  (if (string-starts-with-one-of
+	       current-char (append whitespaces *supported-brackets*))
+	      (setf idx (length local-str))
+	      (push-string current-char result)))))))
+
+
+(defgeneric set-functions (construct filter-string)
+  (:documentation "Transforms all supported functions of the form
+                   function(x, y) to (function x y).")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (find-functions filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((fun-name
+		  (return-if-starts-with (subseq filter-string op-pos)
+					 *supported-functions*))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string
+				    (+ op-pos (length fun-name))))
+		 (cleaned-right-str (trim-whitespace-left right-str))
+		 (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))))))
+	    (set-functions construct modified-str))))))
+
+
+(defun clean-function-arguments (argument-string)
+  "Transforms all arguments within an argument list of the form
+   (x, y, z, ...) to x y z."
+  (declare (String argument-string))
+  (when (and (string-starts-with argument-string "(")
+	     (string-ends-with argument-string ")"))
+    (let ((local-str (subseq argument-string 1 (1- (length argument-string))))
+	  (result ""))
+      (dotimes (idx (length local-str) result)
+	(let ((current-char (subseq local-str idx (1+ idx))))
+	  (if (and (string= current-char ",")
+		   (not (in-literal-string-p local-str idx)))
+	      (push-string " " result)
+	      (push-string current-char result)))))))
+
+
+(defun find-functions (filter-string)
+  "Returns the idx of the first found 'BOUND', 'isLITERAL', 'STR',
+   'DATATYPE', or 'REGEX'.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let* ((first-pos
+	  (search-first-ignore-literals *supported-functions*
+					filter-string)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (not (string-ends-with left-part "("))
+	    first-pos
+	    (let ((next-pos
+		   (find-functions (subseq filter-string (1+ first-pos)))))
+	      (when next-pos
+		(+ 1 first-pos next-pos))))))))
+
+
+(defgeneric set-compare-operators (construct filter-string)
+  (:documentation "Transforms the =, !=, <, >, <= and >= operators in the
+                   filter string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (find-compare-operators filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((op-str (if (string-starts-with-one-of
+			      (subseq filter-string op-pos)
+			      (*2-compare-operators*))
+			     (subseq filter-string op-pos (+ 2 op-pos))
+			     (subseq filter-string op-pos (1+ op-pos))))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (+ (length op-str) op-pos)))
+		 (left-scope (find-compare-left-scope left-str))
+		 (right-scope (find-compare-right-scope right-str))
+		 (modified-str
+		  (concat (subseq left-str 0 (- (length left-str)
+						(length left-scope)))
+			  "(" op-str " " left-scope " " right-scope ")"
+			  (subseq right-str (length right-scope)))))
+	    (set-compare-operators construct modified-str))))))
+
+
+(defun find-compare-operators (filter-string)
+  "Returns the idx of the first found =, !=, <, >, <= or >= operator.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let* ((first-pos
+	  (search-first-ignore-literals *supported-compare-operators*
+					filter-string))
+	 (delta (if first-pos
+		    (if (string-starts-with-one-of
+			 (subseq filter-string first-pos)
+			 (*2-compare-operators*))
+			2
+			1)
+		    1)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (not (string-ends-with-one-of
+		  left-part (append (*1-compare-operators*) (list "("))))
+	    first-pos
+	    (let ((next-pos
+		   (find-compare-operators (subseq filter-string (+ delta first-pos)))))
+	      (when next-pos
+		(+ delta first-pos next-pos))))))))
+
+
+(defun find-compare-left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value
+	      (+ 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)))))
+	 (start-idx (or first-bracket paranthesis-pair-idx 0)))
+    (subseq left-string start-idx)))
+
+
+(defun find-compare-right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos
+	  (search-first-ignore-literals *supported-compare-operators*
+					right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx (cond (paranthesis-pair-idx
+			 paranthesis-pair-idx)
+			((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       0
+			       (length right-string))))))
+    (subseq right-string 0 end-idx)))
+
+
+(defgeneric set-arithmetic-operators (construct filter-string)
+  (:documentation "Transforms the +, -, *, / operators in the filter
+                   string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((filter-string-*/ (set-*-and-/-operators construct filter-string)))
+      (set-+-and---operators construct filter-string-*/))))
+
+
+(defun find-*/-operators (filter-string)
+  "Returns the idx of the first found * or / operator.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let ((first-pos
+	 (search-first-ignore-literals *supported-primary-arithmetic-operators*
+				       filter-string)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (not (string-ends-with left-part "("))
+	    first-pos
+	    (let ((next-pos
+		   (find-*/-operators (subseq filter-string (1+ first-pos)))))
+	      (when next-pos
+		(+ 1 first-pos next-pos))))))))
+
+
+(defgeneric set-*-and-/-operators (construct filter-string)
+  (:documentation "Transforms the *, / operators in the filter
+                   string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (find-*/-operators filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((op-str (subseq filter-string op-pos (1+ op-pos)))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (1+ op-pos)))
+		 (left-scope (find-*/-left-scope left-str))
+		 (right-scope (find-*/-right-scope right-str))
+		 (modified-str
+		  (concat
+		   (subseq left-str 0 (- (length left-str)
+					 (length left-scope)))
+		   "(" op-str " " left-scope " " right-scope ")"
+		   (subseq right-str (length right-scope)))))
+	    (set-*-and-/-operators construct modified-str))))))
+
+
+(defun find-*/-left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value
+	      (+ inner-value (1+ (length (name-after-paranthesis
+					  (subseq left-string inner-value))))))))
+	 (other-anchor
+	  (let ((inner-value
+		 (search-first-ignore-literals
+		  (append *supported-secundary-arithmetic-operators*
+			  *supported-compare-operators*)
+		  left-string :from-end t)))
+	    (when inner-value
+	      (1+ 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)))))
+	 (start-idx (cond (paranthesis-pair-idx
+			   paranthesis-pair-idx)
+			  ((and first-bracket other-anchor)
+			   (max first-bracket other-anchor))
+			  ((or first-bracket other-anchor)
+			   (or first-bracket other-anchor))
+			  (t 0))))
+    (subseq left-string start-idx)))
+
+
+(defun find-*/-right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos (search-first-ignore-literals
+		     (append (*supported-arithmetic-operators*)
+			     *supported-compare-operators*)
+		     right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx (cond (paranthesis-pair-idx
+			 paranthesis-pair-idx)
+			((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       (1- (length right-string)))))))
+    (subseq right-string 0 end-idx)))
+
+
+(defgeneric set-+-and---operators (construct filter-string)
+  (:documentation "Transforms the +, - operators in the filter
+                   string to the the corresponding lisp functions.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((op-pos (find-+--operators filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((op-str (subseq filter-string op-pos (1+ op-pos)))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (1+ op-pos)))
+		 (left-scope (find-+--left-scope left-str))
+		 (right-scope (find-+--right-scope right-str))
+		 (modified-str
+		  (concat (subseq left-str 0 (- (length left-str)
+						(length left-scope)))
+			  "(" op-str " " left-scope " " right-scope ")"
+			  (subseq right-str (length right-scope)))))
+	    (set-+-and---operators construct modified-str))))))
+
+
+(defun find-+--left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value
+	      (+ inner-value (1+ (length (name-after-paranthesis
+					  (subseq left-string inner-value))))))))
+	 (other-anchor
+	  (let ((inner-value
+		 (search-first-ignore-literals *supported-compare-operators*
+					       left-string :from-end t)))
+	    (when inner-value
+	      (1+ 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)))))
+	 (start-idx (cond (paranthesis-pair-idx
+			   paranthesis-pair-idx)
+			  ((and first-bracket other-anchor)
+			   (max first-bracket other-anchor))
+			  ((or first-bracket other-anchor)
+			   (or first-bracket other-anchor))
+			  (t 0))))
+    (subseq left-string start-idx)))
+
+
+(defun find-+--right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos (search-first-ignore-literals
+		     (append (*supported-arithmetic-operators*)
+			     *supported-compare-operators*)
+		     right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx (cond (paranthesis-pair-idx
+			 paranthesis-pair-idx)
+			((and first-pos first-bracket)
+			 (min first-pos first-bracket))
+			(first-pos first-pos)
+			(first-bracket first-bracket)
+			(t (if (= (length right-string) 0)
+			       (1- (length right-string)))))))
+    (subseq right-string 0 end-idx)))
+
+
+(defun find-+--operators (filter-string)
+  "Returns the idx of the first found + or - operator.
+   It must not be in a literal string or directly after a (."
+  (declare (String filter-string))
+  (let ((first-pos
+	 (search-first-ignore-literals *supported-secundary-arithmetic-operators*
+				       filter-string)))
+    (when first-pos
+      (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+	(if (and (not (string-ends-with left-part "(one"))
+		 (not (string-ends-with left-part "(")))
+	    first-pos
+	    (let ((next-pos
+		   (find-+--operators (subseq filter-string (1+ first-pos)))))
+	      (when next-pos
+		(+ 1 first-pos next-pos))))))))
+
+
+(defgeneric set-or-and-operators (construct filter-string original-filter-string)
+  (:documentation "Transforms the || and && operators in the filter string to
+                   the the lisp or and and functions.")
+  (:method ((construct SPARQL-Query) (filter-string String)
+	    (original-filter-string String))
+    (let ((op-pos (search-first-ignore-literals
+		   *supported-join-operators* filter-string)))
+      (if (not op-pos)
+	  filter-string
+	  (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
+		 (left-str (subseq filter-string 0 op-pos))
+		 (right-str (subseq filter-string (+ (length op-str) op-pos)))
+		 (left-scope (find-or-and-left-scope left-str))
+		 (right-scope (find-or-and-right-scope right-str))
+		 (modified-str
+		  (concat (subseq left-str 0 (- (length left-str)
+						(length left-scope)))
+			  "(" (if (string= op-str "||") "or" "and") " "
+			  "(progn " left-scope ")" "(progn " right-scope ")) "
+			  (subseq right-str (length right-scope)))))
+	    (when (or (= (length (trim-whitespace left-scope)) 0)
+		      (= (length (trim-whitespace right-scope)) 0))
+	      (error (make-condition
+		      'sparql-parser-error
+		      :message (format nil "Invalid filter: \"~a\", expect an RDF term after and before: \"~a\"" original-filter-string op-str))))
+	    (set-or-and-operators construct modified-str original-filter-string))))))
+
+
+(defun find-binary-op-string (filter-string idx)
+  "Returns the operator as string that is placed on the position idx."
+  (let* ((2-ops
+	  (remove-null (map 'list #'(lambda(op-string)
+				      (when (= (length op-string) 2)
+					op-string))
+			    (*supported-binary-operators*))))
+	 (operator-str (subseq filter-string idx)))
+    (if (string-starts-with-one-of operator-str 2-ops)
+	(subseq operator-str 0 2)
+	(subseq operator-str 0 1))))
+
+
+(defun find-or-and-left-scope (left-string)
+  "Returns the string that is the left part of the binary scope."
+  (declare (String left-string))
+  (let* ((first-bracket
+	  (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+	    (when inner-value 
+	      (+ inner-value (1+ (length (name-after-paranthesis
+					  (subseq left-string inner-value))))))))
+	 
+	 (start-idx (if first-bracket
+			first-bracket
+			0)))
+    (subseq left-string start-idx)))
+
+
+(defun name-after-paranthesis (str)
+  "Returns the substring that is contained after the paranthesis.
+   str must start with a ( otherwise the returnvalue is nil."
+  (declare (String str))
+  (let ((result "")
+	(non-whitespace-found nil))
+  (when (string-starts-with str "(")
+    (let ((cleaned-str (subseq str 1)))
+      (dotimes (idx (length cleaned-str))
+	(let ((current-char (subseq cleaned-str idx (1+ idx))))
+	  (cond ((string-starts-with-one-of current-char (list "(" ")"))
+		 (setf idx (length cleaned-str)))
+		((and non-whitespace-found
+		      (white-space-p current-char))
+		 (setf idx (length cleaned-str)))
+		((white-space-p current-char)
+		 (push-string current-char result))
+		(t
+		 (push-string current-char result)
+		 (setf non-whitespace-found t)))))
+      result))))
+
+
+(defun find-or-and-right-scope (right-string)
+  "Returns the string that is the right part of the binary scope."
+  (declare (String right-string))
+  (let* ((first-pos (search-first-ignore-literals
+		     *supported-join-operators* right-string))
+	 (first-bracket
+	  (let ((inner-value (search-first-unopened-paranthesis right-string)))
+	    (when inner-value (1+ inner-value))))
+	 (paranthesis-pair-idx
+	  (let* ((cleaned-str (trim-whitespace-left right-string))
+		 (bracket-scope (bracket-scope cleaned-str)))
+	    (when bracket-scope
+	      (+ (- (length right-string) (length cleaned-str))
+		 (length bracket-scope)))))
+	 (end-idx
+	  (cond ((and first-pos first-bracket)
+		 (if (< first-pos first-bracket)
+		     (if paranthesis-pair-idx
+			 (if (< first-pos paranthesis-pair-idx)
+			     paranthesis-pair-idx
+			     first-pos)
+			 first-pos)
+		     first-bracket))
+		(first-bracket first-bracket)
+		(first-pos
+		 (if paranthesis-pair-idx
+		     (if (< first-pos paranthesis-pair-idx)
+			 paranthesis-pair-idx
+			 first-pos)
+		     first-pos))
+		(t
+		 (if (= (length right-string) 0)
+		     0
+		     (length right-string))))))
+    (subseq right-string 0 end-idx)))
+
+
+(defgeneric set-unary-operators (construct filter-string)
+  (:documentation "Transforms the unary operators !, +, - to (not ),
+                   (one+ ) and (one- ). The return value is a modified filter
+                   string.")
+  (:method ((construct SPARQL-Query) (filter-string String))
+    (let ((result-string ""))
+      (dotimes (idx (length filter-string))
+	(let ((current-char (subseq filter-string idx (1+ idx))))
+	  (cond ((string= current-char "!")
+		 (if (and (< idx (1- (length filter-string)))
+			  (string= (subseq filter-string (1+ idx) (+ 2 idx)) "="))
+		     (push-string current-char result-string)
+		     (let ((result (unary-operator-scope filter-string idx)))
+		       (push-string "(not " result-string)
+		       (push-string (set-unary-operators construct (getf result :scope))
+				    result-string)
+		       (push-string ")" result-string)
+		       (setf idx (- (1- (length filter-string))
+				    (length (getf result :next-query)))))))
+		((or (string= current-char "-")
+		     (string= current-char "+"))
+		 (let ((string-before
+			(trim-whitespace-right (subseq filter-string 0 idx))))
+		   (if (or (string= string-before "")
+			   (string-ends-with string-before "(progn")
+			   (string-ends-with-one-of
+			    string-before (append (*supported-operators*) (list "("))))
+		       (let ((result (unary-operator-scope filter-string idx)))
+			 (push-string (concat "(one" current-char " ")
+				      result-string)
+			 (push-string (set-unary-operators construct
+							   (getf result :scope))
+				      result-string)
+			 (push-string ")" result-string)
+			 (setf idx (- (1- (length filter-string))
+				      (length (getf result :next-query)))))
+		       (push-string current-char result-string))))
+		((or (string= current-char "'")
+		     (string= current-char "\""))
+		 (let ((literal
+			(get-literal (subseq filter-string idx))))
+		   (if literal
+		       (progn
+			 (setf idx (- (1- (length filter-string))
+				      (length (getf literal :next-string))))
+			 (push-string (getf literal :literal) result-string))
+		       (push-string current-char result-string))))
+		(t
+		 (push-string current-char result-string)))))
+      result-string)))
+
+
+(defun unary-operator-scope (filter-string idx)
+  "Returns a list of the form (:next-query <string> :scope <string>).
+   scope contains the statement that is in the scope of one of the following
+   operators !, +, -."
+  (declare (String filter-string)
+	   (Integer idx))
+  (let* ((string-after (subseq filter-string (1+ idx)))
+	 (cleaned-str (cut-comment string-after)))
+    (cond ((string-starts-with cleaned-str "(")
+	   (let ((result (bracket-scope cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  ((or (string-starts-with cleaned-str "?")
+	       (string-starts-with cleaned-str "$"))
+	   (let ((result (get-filter-variable cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  ((string-starts-with cleaned-str "\"")
+	   (let ((result (get-literal cleaned-str :quotation "\"")))
+	     (list :next-query (getf result :next-string)
+		   :scope (getf result :literal))))
+	  ((string-starts-with-digit cleaned-str)
+	   (let ((result (separate-leading-digits cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  ((string-starts-with cleaned-str "true")
+	   (list :next-query (string-after cleaned-str "true")
+		 :scope "true"))
+	  ((string-starts-with cleaned-str "false")
+	   (list :next-query (string-after cleaned-str "false")
+		 :scope "false"))
+	  ((let ((pos (search-first *supported-functions* cleaned-str)))
+	     (when pos
+	       (= pos 0)))
+	   (let ((result (function-scope cleaned-str)))
+	     (list :next-query (string-after cleaned-str result)
+		   :scope result)))
+	  (t
+	   (error
+	    (make-condition
+	     'sparql-parser-error
+	     :message
+	     (format
+	      nil "Invalid filter: \"~a\". An unary operator must be followed by ~a"
+	      filter-string
+	      "a number, boolean, string, function or a variable")))))))
+
+
+(defun function-scope (str)
+  "If str starts with a supported function there is given the entire substr
+   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))
+	 (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)))))
+    (when fun-suffix
+      (let* ((args (bracket-scope fun-suffix))
+	     (fun-name (string-until cleaned-str args)))
+	(concat fun-name args)))))
+
+
+(defun get-filter-variable (str)
+  "Returns the substring of str if str starts with ? or $ until the variable ends,
+   otherwise the return value is nil."
+  (declare (String str))
+  (when (or (string-starts-with str "?")
+	    (string-starts-with str "$"))
+    (let ((found-end (search-first (append (white-space) (*supported-operators*)
+					   *supported-brackets* (list "?" "$"))
+				   (subseq str 1))))
+      (if found-end
+	  (subseq str 0 (1+ found-end))
+	  str))))
+
+
+(defun reverse-bracket-scope (str &key (open-bracket "(") (close-bracket ")"))
+  "If str ends with close-bracket there will be returned the substring until
+   the matching open-bracket is found. Otherwise the return value is nil."
+  (declare (String str open-bracket close-bracket))
+  (when (string-ends-with str close-bracket)
+    (let ((local-str (subseq str 0 (1- (length str))))
+	  (result ")")
+	  (close-brackets 1))
+      (do ((idx (1- (length local-str)))) ((< idx 0))
+	(let ((current-char (subseq local-str idx (1+ idx))))
+	  (push-string current-char result)
+	  (cond ((string= current-char open-bracket)
+		 (when (not (in-literal-string-p local-str idx))
+		   (decf close-brackets))
+		 (when (= close-brackets 0)
+		   (setf idx 0)))
+		((string= current-char close-bracket)
+		 (when (not (in-literal-string-p local-str idx))
+		   (incf close-brackets)))))
+	(decf idx))
+      (reverse result))))
+
+
+(defun bracket-scope (str &key (open-bracket "(") (close-bracket ")"))
+  "If str starts with open-bracket there will be returned the substring until
+   the matching close-bracket is found. Otherwise the return value is nil."
+  (declare (String str open-bracket close-bracket))
+  (when (string-starts-with str open-bracket)
+    (let ((open-brackets 0)
+	  (result ""))
+      (dotimes (idx (length str))
+	(let ((current-char (subseq str idx (1+ idx))))
+	  (cond ((or (string= "'" current-char)
+		     (string= "\"" current-char))
+		 (let ((literal (get-literal (subseq str idx))))
+		   (if literal
+		       (progn
+			 (setf idx (- (1- (length str))
+				      (length (getf literal :next-string))))
+			 (push-string (getf literal :literal) result))
+		       (progn
+			 (setf result nil)
+			 (setf idx (length str))))))
+		((string= current-char close-bracket)
+		 (decf open-brackets)
+		 (push-string current-char result)
+		 (when (= open-brackets 0)
+		   (setf idx (length str))))
+		((string= current-char open-bracket)
+		 (incf open-brackets)
+		 (push-string current-char result))
+		(t
+		 (push-string current-char result)))))
+      result)))
+
+
+(defgeneric set-boundings (construct query-string)
+  (:documentation "Returns a list of the form (:next-query <string>
+                   :filter-string <string>). next-query is a string containing
+                   the query after the filter and filter is a string
+                   containing the actual filter. Additionally all free
+                   '(' are transformed into '(progn' and all ', ''', \"\"\"
+                   are transformed into \".")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((filter-string "")
+	  (open-brackets 0)
+	  (result nil))
+      (dotimes (idx (length query-string))
+	(let ((current-char (subseq query-string idx (1+ idx))))
+	  (cond ((string= "(" current-char)
+		 (setf open-brackets (1+ open-brackets))
+		 (if (progn-p query-string idx)
+		     (push-string "(progn " filter-string)
+		     (push-string current-char filter-string)))
+		((string= ")" current-char)
+		 (setf open-brackets (1- open-brackets))
+		 (when (< open-brackets 0)
+		   (error
+		    (make-sparql-parser-condition
+		     (subseq query-string idx)
+		     (original-query construct)
+		     "an opening bracket \"(\" is missing for the current closing one")))
+		 (push-string current-char filter-string))
+		((or (string= "'" current-char)
+		     (string= "\"" current-char))
+		 (let ((result
+			(get-literal (subseq query-string idx) :quotation "\"")))
+		   (unless result
+		     (error (make-sparql-parser-condition
+			     (subseq query-string idx)
+			     (original-query construct)
+			     "a closing character for the given literal")))
+		   (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
+		       (list :next-query (subseq query-string idx)
+			     :filter-string filter-string))
+		 (setf idx (1- (length query-string))))
+		((string= current-char "}")
+		 (when (/= open-brackets 0)
+		   (error (make-sparql-parser-condition
+			   (subseq query-string idx)
+			   (original-query construct)
+			   (format nil
+				   "a valid filter, but the filter is not complete, ~a"
+				   (if (> open-brackets 0)
+				       (format nil "~a ')' is missing"
+					       open-brackets)
+				       (format nil "~a '(' is missing"
+					       open-brackets))))))
+		 (setf result
+		       (list :next-query (subseq query-string idx)
+			     :filter-string filter-string)))
+		(t
+		 (push-string current-char filter-string)))))
+      result)))
+
+
+(defun progn-p(query-string idx)
+  "Returns t if the ( at position idx in the filter string
+  represents a (progn) block."
+  (declare (String query-string)
+	   (Integer idx))
+  (let* ((delimiters (append (list " " "," (string #\Space) (string #\Tab)
+				   (string #\Newline) (string #\cr) "(" ")")
+			     (*supported-operators*)))
+	 (string-before (trim-whitespace-right (subseq query-string 0 idx)))
+	 (fragment-before-idx
+	  (search-first delimiters string-before :from-end t))
+	 (fragment-before
+	  (if (and (not fragment-before-idx)
+		   (and (> (length string-before) 0)
+			(not (string-ends-with-one-of
+			      (trim-whitespace-right string-before)
+			      *supported-functions*))))
+	      (error (make-condition
+		      'SPARQL-PARSER-ERROR
+		      :message (format nil "Invalid filter: \"~a\"~%"
+				       query-string)))
+	      (if fragment-before-idx
+		  (subseq string-before fragment-before-idx)
+		  nil))))
+    (when fragment-before
+      (mapcan #'(lambda(operator)
+		  (when (and (string-starts-with fragment-before operator)
+			     (> (length fragment-before) (length operator)))
+		    (setf fragment-before
+			  (string-after fragment-before operator))))
+	      (append (*supported-operators*) *supported-brackets*)))
+    (if fragment-before
+	(progn
+	  (when (or (string-starts-with fragment-before "?")
+		    (string-starts-with fragment-before "$"))
+	    (error
+	     (make-condition
+	      'SPARQL-PARSER-ERROR
+	      :message (format nil "Invalid filter: found \"~a\" but expected ~a"
+			       fragment-before *supported-functions*))))
+	  (when (not (string-starts-with-one-of
+		      fragment-before (append *supported-functions* delimiters)))
+	    (error
+	     (make-condition
+	      'SPARQL-PARSER-ERROR
+	      :message
+	      (format nil "Invalid character: \"~a\", expected characters: ~a"
+		      fragment-before (append *supported-functions* delimiters)))))
+	  (if (string-ends-with-one-of fragment-before *supported-functions*)
+	      nil
+	      t))
+	(if (find string-before *supported-functions* :test #'string=)
+	    nil
+	    t))))
+
+
+(defun get-variables-from-filter-string(filter-string)
+  "Returns a list of string with all variables that are used in this filter."
+  (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)))))
+    (remove-duplicates variables :test #'string=)))
\ No newline at end of file

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_parser.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_parser.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,476 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :TM-SPARQL)
+
+(defun parse-closed-value(query-string query-object &key (open "<") (close ">"))
+  "A helper function that checks the value of a statement within
+   two brackets, i.e. <prefix-value>. A list of the
+   form (:next-query string :value string) is returned."
+  (declare (String query-string open close)
+	   (SPARQL-Query query-object))
+  (let ((trimmed-string (cut-comment query-string)))
+    (if (string-starts-with trimmed-string open)
+	(let* ((pref-url (string-until (string-after trimmed-string open) close))
+	       (next-query-str (string-after trimmed-string close)))
+	  (unless next-query-str
+	    (error (make-sparql-parser-condition
+		    trimmed-string (original-query query-object)
+		    close)))
+	  (list :next-query next-query-str
+		:value pref-url))
+	(error (make-sparql-parser-condition
+		trimmed-string (original-query query-object)
+		close)))))
+
+
+(defun cut-comment (query-string)
+  "Returns the given string back. If the query starts with a # or
+   space # the characters until the nextline are removed."
+  (declare (String query-string))
+  (let ((trimmed-str (trim-whitespace-left query-string)))
+    (if (string-starts-with trimmed-str "#")
+        (let ((next-query (string-after trimmed-str (string #\newline))))
+	  (if next-query
+	      next-query
+	      ""))
+	trimmed-str)))
+
+
+(defgeneric parser-start(construct query-string)
+  (:documentation "The entry point of the SPARQL-parser.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((trimmed-query-string (cut-comment query-string)))
+      (cond ((string-starts-with trimmed-query-string "SELECT")
+	     (parse-select
+	      construct (string-after trimmed-query-string "SELECT")))
+	    ((string-starts-with trimmed-query-string "PREFIX")
+	     (parse-prefixes
+	      construct (string-after trimmed-query-string "PREFIX")))
+	    ((string-starts-with trimmed-query-string "BASE")
+	     (parse-base construct (string-after trimmed-query-string "BASE")
+			 #'parser-start))
+	    ((= (length trimmed-query-string) 0)
+	     ;; If there is only a BASE and/or PREFIX statement return a
+	     ;; query-object with the result nil
+	     construct)
+	    (t
+	     (error (make-sparql-parser-condition
+		     trimmed-query-string (original-query construct)
+		     (format nil "SELECT, PREFIX or BASE, but found: ~a..."
+			     (subseq trimmed-query-string 0 10)))))))))
+
+
+(defgeneric parse-select (construct query-string)
+  (:documentation "The entry-point of the parsing of the select - where
+                   statement.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (next-query (if (string-starts-with trimmed-str "WHERE")
+			   trimmed-str
+			   (parse-variables construct trimmed-str))))
+      (unless (string-starts-with next-query "WHERE")
+	(error (make-sparql-parser-condition
+		next-query (original-query construct) "WHERE")))
+      (let* ((triples (string-after next-query "WHERE"))
+	     (query-tail (parse-where construct triples)))
+	(when (> (length query-tail) 0)
+	  (error (make-sparql-parser-condition
+		  query-tail (original-query construct)
+		  "The end of the query. Solution sequence modifiers are not supported yet.")))
+	construct))))
+
+
+(defgeneric parse-where (construct query-string)
+  (:documentation "The entry-point for the parsing of the WHERE statement.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((trimmed-str (cut-comment query-string)))
+      (unless (string-starts-with trimmed-str "{")
+	(error (make-sparql-parser-condition trimmed-str
+					     (original-query construct) "{")))
+      (let ((query-tail (parse-group construct (subseq trimmed-str 1))))
+	(when (> (length (trim-whitespace query-tail)) 0)
+	  (make-sparql-parser-condition
+	   query-tail (original-query construct) "end of query, solution sequences and modifiers are not supported"))
+	query-tail))))
+
+
+(defgeneric parse-group (construct query-string &key last-subject)
+  (:documentation "The entry-point for the parsing of a {} statement.")
+  (:method ((construct SPARQL-Query) (query-string String)
+	    &key (last-subject nil))
+    (declare (type (or Null SPARQL-Triple-Elem) last-subject))
+    (let ((trimmed-str (cut-comment query-string)))
+      (cond ((string-starts-with trimmed-str "BASE")
+	     (parse-base construct (string-after trimmed-str "BASE")
+			 #'(lambda(constr query-str)
+			     (parse-group constr query-str
+					  :last-subject last-subject))))
+	    ((string-starts-with trimmed-str "{")
+	     (error (make-sparql-parser-condition
+		     trimmed-str (original-query construct)
+		     "FILTER, BASE, or triple. Grouping is currently no implemented.")))
+	    ((string-starts-with trimmed-str "FILTER")
+	     (parse-filter construct (string-after trimmed-str "FILTER")))
+	    ((string-starts-with trimmed-str "OPTIONAL")
+	     (error (make-sparql-parser-condition
+		     trimmed-str (original-query construct)
+		     "FILTER, BASE, or triple. Grouping is currently no implemented.")))
+	    ((string-starts-with trimmed-str "UNION")
+	     (error (make-sparql-parser-condition
+		     trimmed-str (original-query construct)
+		     "FILTER, BASE, or triple. Grouping is currently no implemented.")))
+	    ((string-starts-with trimmed-str "}") ;ending of this group
+	     (subseq trimmed-str 1))
+	    (t
+	     (parse-triple construct trimmed-str :last-subject last-subject))))))
+
+
+(defgeneric parse-triple-elem (construct query-string &key literal-allowed)
+  (:documentation "A helper function to parse a subject or predicate of an RDF triple.")
+  (:method ((construct SPARQL-Query) (query-string String)
+	    &key (literal-allowed nil))
+    (declare (Boolean literal-allowed))
+    (let ((trimmed-str (cut-comment query-string)))
+      (cond ((string-starts-with trimmed-str "a ") ;;rdf:type
+	     (list :next-query (cut-comment (subseq trimmed-str 1))
+		   :value (make-instance 'SPARQL-Triple-Elem
+					 :elem-type 'IRI
+					 :value *type-psi*)))
+	    ((string-starts-with trimmed-str "<")
+	     (parse-base-suffix-pair construct trimmed-str))
+	    ((or (string-starts-with trimmed-str "?")
+		 (string-starts-with trimmed-str "$"))
+	     (let ((result
+		    (parse-variable-name construct trimmed-str
+					 :additional-delimiters (list "}"))))
+	       (list :next-query (cut-comment (getf result :next-query))
+		     :value (make-instance 'SPARQL-Triple-Elem
+					   :elem-type 'VARIABLE
+					   :value (getf result :value)))))
+	    (t
+	     (if (or (string-starts-with-digit trimmed-str)
+		     (string-starts-with trimmed-str "\"")
+		     (string-starts-with trimmed-str "true")
+		     (string-starts-with trimmed-str "false")
+		     (string-starts-with trimmed-str "'"))
+		 (progn
+		   (unless literal-allowed
+		     (error (make-sparql-parser-condition
+			     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)))))))
+
+
+(defgeneric parse-literal-elem (construct query-string)
+  (:documentation "A helper-function that returns a literal vaue of the form
+                   (:value (:value object :literal-type string :literal-lang
+                   string :type <'LITERAL>) :next-query string).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (value-type-lang-query
+	    (cond ((or (string-starts-with trimmed-str "\"")
+		       (string-starts-with trimmed-str "'"))
+		   (parse-literal-string-value construct trimmed-str))
+		  ((string-starts-with trimmed-str "true")
+		   (list :value t :type *xml-boolean*
+			 :next-query (subseq trimmed-str (length "true"))))
+		  ((string-starts-with trimmed-str "false")
+		   (list :value nil :type *xml-boolean*
+			 :next-query (subseq trimmed-str (length "false"))))
+		  ((string-starts-with-digit trimmed-str)
+		   (parse-literal-number-value construct trimmed-str)))))
+      (list :next-query (getf value-type-lang-query :next-query)
+	    :value (make-instance
+		    'SPARQL-Triple-Elem
+		    :elem-type 'LITERAL
+		    :value (getf value-type-lang-query :value)
+		    :literal-lang (getf value-type-lang-query :lang)
+		    :literal-datatype (getf value-type-lang-query :type))))))
+  
+  
+(defgeneric parse-literal-string-value (construct query-string)
+  (:documentation "A helper function that parses a string that is a literal.
+                   The return value is of the form
+                   (list :value object :type string :lang string
+                   :next-query string).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (result-1 (separate-literal-value construct trimmed-str))
+	   (after-literal-value (getf result-1 :next-query))
+	   (l-value (getf result-1 :literal))
+	   (result-2 (separate-literal-lang-or-type
+		      construct after-literal-value))
+	   (l-type (if (getf result-2 :type)
+		       (getf result-2 :type)
+		       *xml-string*))
+	   (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)))))
+
+
+(defgeneric separate-literal-lang-or-type (construct query-string)
+  (:documentation "A helper function that returns (:next-query string
+                   :lang string :type string). Only one of :lang and
+                   :type can be set, the other element is set to nil.
+                   The query string must be the string direct after
+                   the closing literal bounding.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((delimiters-1 (list "." ";" "}" " " (string #\tab)
+			      (string #\newline)))
+	  (delimiters-2 (list " ." ". " ";" "}" " " (string #\tab)
+			      (string #\newline)
+			      (concat "." (string #\newline))
+			      (concat "." (string #\tab)))))
+      (cond ((string-starts-with query-string "@")
+	     (let ((end-pos (search-first delimiters-1
+					  (subseq query-string 1))))
+	       (unless end-pos
+		 (error (make-sparql-parser-condition
+			 query-string (original-query construct)
+			 "'.', ';', '}', ' ', '\t', or '\n'")))
+	       (list :next-query (subseq (subseq query-string 1) end-pos)
+		     :lang (subseq (subseq query-string 1) 0 end-pos)
+		     :type nil)))
+	    ((string-starts-with query-string "^^")
+	     (let ((end-pos (search-first delimiters-2 (subseq query-string 2))))
+	       (unless end-pos
+		 (error (make-sparql-parser-condition
+			 query-string (original-query construct)
+			 "'. ', ,' .', ';', '}', ' ', '\t', or '\n'")))
+	       (let* ((type-str (subseq (subseq query-string 2) 0 end-pos))
+		      (next-query (subseq (subseq query-string 2) end-pos))
+		      (final-type (if (get-prefix construct type-str)
+				      (get-prefix construct type-str)
+				      type-str)))
+		 (list :next-query (cut-comment next-query)
+		       :type final-type :lang nil))))
+	    (t
+	     (list :next-query (cut-comment query-string) :type nil :lang nil))))))
+
+
+(defgeneric separate-literal-value (construct query-string)
+  (:documentation "A helper function that returns (:next-query string
+                   :literal string). The literal string contains the
+                   pure literal value.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (delimiter (cond ((string-starts-with trimmed-str "\"")
+			     "\"")
+			    ((string-starts-with trimmed-str "'''")
+			     "'''")
+			    ((string-starts-with trimmed-str "'")
+			     "'")
+			    (t
+			     (error (make-sparql-parser-condition
+				     trimmed-str (original-query construct)
+				     "a literal starting with ', ''', or \"")))))
+	   (literal-end (find-literal-end (subseq trimmed-str (length delimiter))
+					  delimiter 0)))
+      (list :next-query (subseq trimmed-str (+ literal-end (length delimiter)))
+	    :literal (subseq trimmed-str (length delimiter) literal-end)))))
+
+
+(defgeneric parse-literal-number-value (construct query-string)
+  (:documentation "A helper function that parses any number that is a literal.
+                   The return value is of the form
+                  (list :value nil :type string :next-query string.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (triple-delimiters
+	    (list ". " ";" " " (string #\tab)
+		  (string #\newline) "}"))
+	   (end-pos (search-first triple-delimiters
+				  trimmed-str)))
+      (unless end-pos
+	(error (make-sparql-parser-condition
+		trimmed-str (original-query construct)
+		"'. ', , ';' ' ', '\\t', '\\n' or '}'")))
+      (let* ((literal-number
+	      (read-from-string (subseq trimmed-str 0 end-pos)))
+	     (number-type
+	      (if (search "." (subseq trimmed-str 0 end-pos))
+		  *xml-double* ;could also be an xml:decimal, since the doucble has
+			       ;a bigger range it shouldn't matter
+		  *xml-integer*)))
+	(unless (numberp literal-number)
+	  (error (make-sparql-parser-condition
+		  trimmed-str (original-query construct)
+		  "a valid number of the form '1', '1.3', 1.0e6'")))
+	(list :value literal-number :type number-type
+	      :next-query (subseq trimmed-str end-pos))))))
+
+
+(defgeneric parse-base-suffix-pair (construct query-string)
+  (:documentation "A helper function that returns a list of the form
+                  (list :next-query string :value (:value uri :type 'IRI)).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (result (parse-closed-value trimmed-str construct))
+	   (result-uri
+	    (if (or (absolute-uri-p (getf result :value))
+		    (not (base-value construct)))
+		(getf result :value)
+		(concatenate-uri (base-value construct)
+				 (getf result :value))))
+	   (next-query (getf result :next-query)))
+      (list :next-query (cut-comment next-query)
+	    :value (make-instance 'SPARQL-Triple-Elem
+				  :elem-type 'IRI
+				  :value result-uri)))))
+
+
+(defgeneric parse-prefix-suffix-pair(construct query-string)
+  (:documentation "A helper function that returns a list of the form
+                  (list :next-query string :value (:value uri :type 'IRI)).")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (delimiters (list "." ";" "}" "<" " " (string #\newline)
+			     (string #\tab) "#"))
+	   (end-pos (search-first delimiters trimmed-str))
+	   (elem-str (when end-pos
+		       (subseq trimmed-str 0 end-pos)))
+	   (prefix (when elem-str
+		     (string-until elem-str ":")))
+	   (suffix (when prefix
+		     (string-after elem-str ":")))
+	   (full-url
+	    (when (and suffix prefix)
+	      (get-prefix construct (concat prefix ":" suffix)))))
+      (unless (and end-pos prefix suffix)
+	(error (make-sparql-parser-condition
+		trimmed-str (original-query construct)
+		"An IRI of the form prefix:suffix")))
+      (unless full-url
+	(error (make-condition
+		'sparql-parser-error
+		:message (format nil "The prefix in \"~a:~a\" is not registered"
+				 prefix suffix))))
+      (list :next-query (cut-comment
+			 (string-after trimmed-str
+				       (concat prefix ":" suffix)))
+	    :value (make-instance 'SPARQL-Triple-Elem
+				  :elem-type 'IRI
+				  :value full-url)))))
+
+
+(defgeneric parse-triple (construct query-string &key last-subject)
+  (:documentation "Parses a triple within a trippel group.")
+  (:method ((construct SPARQL-Query) (query-string String) &key (last-subject nil))
+    (declare (type (or Null SPARQL-Triple-Elem) last-subject))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (subject-result (if last-subject ;;is used after a ";"
+			       last-subject
+			       (parse-triple-elem construct trimmed-str)))
+	   (predicate-result (parse-triple-elem
+			      construct
+			      (if last-subject
+				  trimmed-str
+				  (getf subject-result :next-query))))
+	   (object-result (parse-triple-elem construct
+					     (getf predicate-result :next-query)
+					     :literal-allowed t)))
+      (add-triple construct
+		  (make-instance 'SPARQL-Triple
+				 :subject (if last-subject
+					      last-subject
+					      (getf subject-result :value))
+				 :predicate (getf predicate-result :value)
+				 :object (getf object-result :value)))
+      (let ((tr-str (cut-comment (getf object-result :next-query))))
+	(cond ((string-starts-with tr-str ";")
+	       (parse-group construct (subseq tr-str 1)
+			    :last-subject (getf subject-result :value)))
+	      ((string-starts-with tr-str ".")
+	       (parse-group construct (subseq tr-str 1)))
+	      ((string-starts-with tr-str "}")
+	       (parse-group construct tr-str)))))))
+
+
+(defgeneric parse-variables (construct query-string)
+  (:documentation "Parses the variables of the SELECT statement
+                   and adds them to the passed construct.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((trimmed-str (cut-comment query-string)))
+      (if (string-starts-with trimmed-str "WHERE")
+	  trimmed-str
+	  (if (string-starts-with trimmed-str "*")
+	      (progn (add-variable construct "*")
+		     (parse-variables construct (string-after trimmed-str "*")))
+	      (let ((result (parse-variable-name construct trimmed-str)))
+		(add-variable construct (getf result :value))
+		(parse-variables construct (getf result :next-query))))))))
+
+
+(defgeneric parse-variable-name (construct query-string &key additional-delimiters)
+  (:documentation "A helper function that parses the first non-whitespace character
+                   in the query. since it must be a variable, it must be prefixed
+                   by a ? or $. The return value is of the form
+                  (:next-query string :value string).")
+  (:method ((construct SPARQL-Query) (query-string String)
+	    &key (additional-delimiters))
+    (declare (List additional-delimiters))
+    (let ((trimmed-str (cut-comment query-string))
+	  (delimiters (append
+		       (list " " "?" "$" "." (string #\newline) (string #\tab))
+		       additional-delimiters)))
+      (unless (or (string-starts-with trimmed-str "?")
+		  (string-starts-with trimmed-str "$"))
+	(error (make-sparql-parser-condition
+		trimmed-str (original-query construct) "? or $")))
+      (let* ((var-name-end (search-first delimiters (subseq trimmed-str 1)))
+	     (var-name
+	      (if var-name-end
+		  (subseq trimmed-str 0 (+ 1 var-name-end))
+		  (error (make-sparql-parser-condition
+			  trimmed-str (original-query construct)
+			  "space, newline, tab, ?, ., $ or WHERE"))))
+	     (next-query (string-after trimmed-str var-name))
+	     (normalized-var-name 
+	      (if (<= (length var-name) 1)
+		  (error (make-sparql-parser-condition
+			  next-query (original-query construct)
+			  "a variable name"))
+		  (subseq var-name 1))))
+	(list :next-query next-query :value normalized-var-name)))))
+
+
+(defgeneric parse-base (construct query-string next-fun)
+  (:documentation "Parses the Base statment and sets the corresponding
+                   attribute in the query-construct. Since the BASE statement
+                   may appear in different states the next-fun defines the next
+                   call function that calls the next transitions and states.")
+  (:method ((construct SPARQL-Query) (query-string String) (next-fun Function))
+    (let* ((trimmed-str (cut-comment query-string))
+	   (result (parse-closed-value trimmed-str construct)))
+      (setf (base-value construct) (getf result :value))
+      (funcall next-fun construct (getf result :next-query)))))
+
+
+(defgeneric parse-prefixes (construct query-string)
+  (:documentation "Sets the correponding prefix-tuples in the passed object.")
+  (:method ((construct SPARQL-Query) (query-string String))
+    (let ((trimmed-string (cut-comment query-string)))
+      (if (string-starts-with trimmed-string ":")
+	  (let ((results
+		 (parse-closed-value (subseq trimmed-string 1) construct)))
+	    (add-prefix construct *empty-label* (getf results :value))
+	    (parser-start construct (getf results :next-query)))
+	  (let* ((label-name
+		  (trim-whitespace-right (string-until trimmed-string ":")))
+		 (next-query-str
+		  (trim-whitespace-left (string-after trimmed-string ":")))
+		 (results (parse-closed-value next-query-str construct)))
+	    (when (string= label-name trimmed-string)
+	      (error (make-sparql-parser-condition
+		      trimmed-string (original-query construct) ":")))
+	    (add-prefix construct label-name (getf results :value))
+	    (parser-start construct (getf results :next-query)))))))
\ No newline at end of file

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_special_uris.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/sparql_special_uris.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,379 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :TM-SPARQL)
+
+
+(defmacro with-triple-nodes (triple-construct &body body)
+  "Generates the variables subj, pred, obj that references the triple's
+   nodes. Additionaly the variables subj-uri, pred-uri and obj-uri are
+   generated when the corresponding node is a resource-nodes."
+  `(let* ((subj (subject ,triple-construct))
+	  (pred (predicate ,triple-construct))
+	  (obj (object ,triple-construct))
+	  (subj-uri (unless (variable-p subj)
+		      (sparql-node (value subj) :revision revision)))
+	  (pred-uri (unless (variable-p pred)
+		      (sparql-node (value pred) :revision revision)))
+	  (obj-uri (when (and (not (variable-p obj))
+			      (not (literal-p obj)))
+		     (sparql-node (value obj) :revision revision)))
+	  (literal-datatype (when (literal-p obj)
+			      (literal-datatype obj))))
+     (declare (Ignorable subj-uri pred-uri obj-uri literal-datatype))
+     , at body))
+
+
+(defgeneric filter-by-special-uris (construct &key revision)
+  (:documentation "Returns lists representing triples that handles special
+                   predicate uris defined in tmsparql.")
+  (:method ((construct SPARQL-Triple) &key (revision d:*TM-REVISION*))
+    (let ((pred (predicate construct))
+	  (pred-val (value (predicate construct))))
+      (if (variable-p pred)
+	  (filter-for-special-uris construct :revision revision)
+	  (cond ((has-identifier pred-val *tms-reifier*)
+		 (filter-for-reifier construct :revision revision))
+		((has-identifier pred-val *tms-scope*)
+		 (filter-for-scopes construct :revision revision))
+		((has-identifier pred-val *tms-value*)
+		 (filter-for-values construct :revision revision))
+		((has-identifier pred-val *tms-topicProperty*)
+		 (filter-for-topicProperties construct :revision revision))
+		((has-identifier pred-val *tms-role*)
+		 (filter-for-roles construct :revision revision))
+		((has-identifier pred-val *tms-player*)
+		 (filter-for-player construct :revision revision)))))))
+
+
+(defgeneric filter-for-special-uris (construct &key revision)
+  (:documentation "Returns a list of triples representing the subject
+                   and its objects corresponding to the defined
+                   special-uris, e.g. <subj> var <obj>.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (let* ((pred (predicate construct))
+	   (old-pred-value (value pred))
+	   (res-1
+	    (progn
+	      (setf (value pred) (get-item-by-psi *tms-reifier* :revision revision))
+	      (let ((val (filter-for-reifier construct :revision revision)))
+		(setf (value pred) old-pred-value)
+		val)))
+	   (res-2
+	    (progn
+	      (setf (value pred) (get-item-by-psi *tms-scope* :revision revision))
+	      (let ((val (filter-for-scopes construct :revision revision)))
+		(setf (value pred) old-pred-value)
+		val)))
+	   (res-3
+	    (progn
+	      (setf (value pred) (get-item-by-psi *tms-value* :revision revision))
+	      (let ((val (filter-for-values construct :revision revision)))
+		(setf (value pred) old-pred-value)
+		val)))
+	   (res-4
+	    (progn
+	      (setf (value pred) (get-item-by-psi *tms-role* :revision revision))
+	      (let ((val (filter-for-roles construct :revision revision)))
+		(setf (value pred) old-pred-value)
+		val)))
+	   (res-5
+	    (progn
+	      (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))))
+      (append res-1 res-2 res-3 res-4 res-5))))
+
+
+(defgeneric filter-for-player (construct &key revision)
+  (:documentation "Returns a list with triples where the subject
+                   represents a role and the object represents a player.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+      (unless (literal-p (object construct))
+	(with-triple-nodes construct
+	  (when (and (or (typep (value subj) 'RoleC)
+			 (variable-p subj))
+		     (or (typep (value obj) 'TopicC)
+			 (variable-p obj)))
+	    (cond ((and (not (variable-p subj))
+			(not (variable-p obj)))
+		   (when (eql (player (value subj) :revision revision)
+			      (value obj))
+		     (list (list :subject subj-uri
+				 :predicate pred-uri
+				 :object obj-uri))))
+		  ((not (variable-p subj))
+		   (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)))))
+		  ((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)
+							   :revision revision)))))
+		  (t ; only pred is given
+		   (let ((all-roles
+			  (remove-null
+			   (map 'list #'(lambda(role)
+					  (when (player role :revision revision)
+					    role))
+				(get-all-roles revision)))))
+		     (loop for role in all-roles
+			collect (list :subject (sparql-node role :revision revision)
+				      :predicate pred-uri
+				      :object (sparql-node (player role :revision revision)
+							   :revision revision)))))))))))
+
+
+(defgeneric filter-for-roles (construct &key revision)
+  (:documentation "Returns a list of triples where the subject represents
+                   an Association and the object represents a role.")
+  (:method((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (unless (literal-p (object construct))
+      (with-triple-nodes construct
+	(when (and (or (variable-p subj)
+		       (typep (value subj) 'd:AssociationC))
+		   (or (variable-p obj)
+		       (typep (value subj) 'd:RoleC)))
+	  (cond ((and (not (variable-p subj))
+		      (not (variable-p obj)))
+		 (when (find obj (roles (value subj) :revision revision))
+		   (list (list :subject subj-uri
+			       :predicate pred-uri
+			       :object obj-uri))))
+		((not (variable-p subj))
+		 (loop for role in (roles (value subj) :revision revision)
+		    collect (list :subject subj-uri
+				  :predicate pred-uri
+				  :object (sparql-node role :revision revision))))
+		((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))))
+		(t ; only pred is given
+		 (let ((assocs
+			(remove-null
+			 (map 'list #'(lambda(assoc)
+					(when (roles assoc :revision revision)
+					  assoc))
+			      (get-all-associations revision)))))
+		   (loop for assoc in assocs
+		      append (loop for role in (roles assoc :revision revision)
+				collect (list :subject (sparql-node
+							assoc :revision revision)
+					      :predicate pred-uri
+					      :object (sparql-node
+						       role :revision revision))))))))))))
+
+
+(defgeneric filter-for-topicProperties (construct &key revision)
+  (:documentation "Returns a list of triples where the subject represents
+                   a topic and the object represents a name or occurrence.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (unless (literal-p (object construct))
+      (with-triple-nodes construct
+	(when (and (or (variable-p subj)
+		       (typep (value subj) 'd:TopicC))
+		   (or (variable-p obj)
+		       (typep (value obj) 'd:OccurrenceC)
+		       (typep (value obj) 'd:NameC)))
+	  (cond ((and (not (variable-p subj))
+		      (not (variable-p obj)))
+		 (when (find obj (append (names (value subj) :revision revision)
+					 (occurrences (value subj) :revision revision)))
+		   (list (list :subject subj-uri
+			       :predicate pred-uri
+			       :object obj-uri))))
+		((not (variable-p subj))
+		 (loop for property in (append
+					(names (value subj) :revision revision)
+					(occurrences (value subj) :revision revision))
+		    collect (list :subject subj-uri
+				  :predicate pred-uri
+				  :object
+				  (sparql-node property :revision revision))))
+		((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))))
+		(t ; only pred is given
+		 (let ((topics
+			(remove-null
+			 (map 'list #'(lambda(top)
+					(when (append
+					       (names top :revision revision)
+					       (occurrences top :revision revision))
+					  top))
+			      (get-all-topics revision)))))
+		   (loop for top in topics
+		      append (loop for prop in (append
+						(names top :revision revision)
+						(occurrences top :revision revision))
+				collect (list :subject (sparql-node
+							top :revision revision)
+					      :predicate pred-uri
+					      :object (sparql-node
+						       prop :revision revision))))))))))))
+
+
+(defgeneric filter-for-values (construct &key revision)
+  (:documentation "Returns a list of triples that represent a
+                   subject and its literal value as object.")
+  (:method ((construct SPARQL-Triple) &key revision)
+    (declare (ignorable revision))
+    (with-triple-nodes construct
+      (when (and (or (variable-p subj)
+		     (typep (value subj) 'd:OccurrenceC)
+		     (typep (value subj) 'd:NameC)
+		     (typep (value subj) 'd:VariantC))
+		 (or (variable-p obj)
+		     (literal-p obj)))
+	(cond ((and (not (variable-p subj))
+		    (not (variable-p obj)))
+	       (when (or (and (typep subj 'NameC)
+			      (string= literal-datatype *xml-string*)
+			      (string= (charvalue 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))))
+	      ((not (variable-p subj))
+	       (list (list :subject subj-uri
+			   :predicate pred-uri
+			   :object (charvalue subj)
+			   :literal-datatype (if (typep subj 'd:NameC)
+						 *xml-string*
+						 (datatype subj)))))
+	      ((not (variable-p obj))
+	       (loop for char in (return-characteristics (value obj) literal-datatype)
+		  collect (list :subject (sparql-node char :revision revision)
+				:predicate pred-uri
+				:object (charvalue char)
+				:literal-datatype (if (typep char 'd:NameC)
+						      *xml-string*
+						      (datatype char)))))
+	      (t ;only pred is given
+	       (let ((chars (append (get-all-names revision)
+				    (get-all-occurrences revision)
+				    (get-all-variants revision))))
+		 (loop for char in chars
+		    collect (list :subject (sparql-node char :revision revision)
+				  :predicate pred-uri
+				  :object (charvalue char)
+				  :literal-datatype (if (typep char 'd:NameC)
+							*xml-string*
+							(datatype char)))))))))))
+
+
+  (defgeneric filter-for-scopes (construct &key revision)
+    (:documentation "Returns a list of triples that represent a subject as the
+                   scoped item and the object as the scope-topic.")
+    (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+      (unless (literal-p (object construct))
+	(with-triple-nodes construct
+	  (when (and (or (variable-p subj)
+			 (typep (value subj) 'd:ScopableC))
+		     (or (variable-p obj)
+			 (typep (value obj) 'd:TopicC)))
+	    (cond ((and (not (variable-p subj))
+			(not (variable-p obj)))
+		   (when (find obj (themes (value subj) :revision revision))
+		     (list (list :subject subj-uri
+				 :predicate pred-uri
+				 :object obj-uri))))
+		  ((not (variable-p subj))
+		   (loop for scope in (themes (value subj) :revision revision)
+		      collect (list :subject subj-uri
+				    :predicate pred-uri
+				    :object (sparql-node scope :revision revision))))
+		  ((not (variable-p obj))
+		   (let ((scoped-constructs
+			  (used-as-theme (value obj) :revision revision)))
+		     (loop for construct in scoped-constructs
+			collect (list :subject (sparql-node construct :revision revision)
+				      :predicate pred-uri
+				      :object obj-uri))))
+		  (t ;only pred is given
+		   (let ((scoped-constructs
+			  (remove-null
+			   (map 'list #'(lambda(construct)
+					  (when (themes construct :revision revision)
+					    construct))
+				(append (get-all-associations revision)
+					(get-all-occurrences revision)
+					(get-all-names revision)
+					(get-all-variants))))))
+		     (loop for construct in scoped-constructs
+			append (loop for scope in (themes construct :revision revision)
+				  collect
+				    (list :subject (sparql-node
+						    construct :revision revision)
+					  :predicate pred-uri
+					  :object (sparql-node
+						   construct :revision revision))))))))))))
+
+
+(defgeneric filter-for-reifier (construct &key revision)
+  (:documentation "Returns a list with triples representing a reifier
+                     and the corresponding reified construct.")
+  (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*))
+    (unless (literal-p (object construct))
+      (with-triple-nodes construct
+	(when (and (or (variable-p subj)
+		       (typep (value subj) 'd:ReifiableConstructC))
+		   (or (variable-p obj)
+		       (typep (value obj) 'd:TopicC)))
+	  (cond ((and (not (variable-p subj))
+		      (not (variable-p obj)))
+		 (when (eql (reifier (value subj) :revision revision)
+			    (value obj))
+		   (list (list :subject subj-uri
+			       :predicate pred-uri
+			       :object obj-uri))))
+		((not (variable-p subj))
+		 (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)))))
+		((not (variable-p obj))
+		 (let ((reified-cons
+			(reified-construct (value obj) :revision revision)))
+		   (when reified-cons
+		     (list (list :subject
+				 (sparql-node reified-cons :revision revision)
+				 :predicate pred-uri
+				 :object obj-uri)))))
+		(t ; only pred is given
+		 (let ((topics
+			(remove-null
+			 (map 'list #'(lambda(top)
+					(when (reified-construct top :revision revision)
+					  top))
+			      (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

Added: trunk/playground/abcl-test/lisp-code/TM-SPARQL/tmsparql_core_psis.xtm
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/TM-SPARQL/tmsparql_core_psis.xtm	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,45 @@
+<?xml version="1.0"?>
+<!-- ======================================================================= -->
+<!--  Isidorus                                                               -->
+<!--  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff          -->
+<!--                                                                         -->
+<!--  Isidorus is freely distributable under the LLGPL license.              -->
+<!--  This ajax module uses the frameworks PrototypeJs and Scriptaculous,    -->
+<!--  both are distributed under the MIT license.                            -->
+<!--  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt,   -->
+<!--  trunk/docs/LGPL-LICENSE.txt and in                                     -->
+<!--  trunk/src/ajax/javascripts/external/MIT-LICENSE.txt.                   -->
+<!-- ======================================================================= -->
+
+
+<!-- this file contains the special uri defined in tmsparql
+     (http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html)
+     as topic with only a psi as element corresponding to those defined in
+     tmsparql -->
+
+<topicMap xmlns="http://www.topicmaps.org/xtm/" version="2.0">
+  <topic id="reifier">
+    <subjectIdentifier href="http://www.networkedplanet.com/tmsparql/reifier"/>
+  </topic>
+
+  <topic id="role">
+    <subjectIdentifier href="http://www.networkedplanet.com/tmsparql/role"/>
+  </topic>
+
+  <topic id="player">
+    <subjectIdentifier href="http://www.networkedplanet.com/tmsparql/player"/>
+  </topic>
+
+  <topic id="topicProperty">
+    <subjectIdentifier href="http://www.networkedplanet.com/tmsparql/topicProperty"/>
+  </topic>
+
+  <topic id="scope">
+    <subjectIdentifier href="http://www.networkedplanet.com/tmsparql/scope"/>
+  </topic>
+
+  <topic id="value">
+    <subjectIdentifier href="http://www.networkedplanet.com/tmsparql/value"/>
+  </topic>
+
+</topicMap>

Added: trunk/playground/abcl-test/lisp-code/base-tools/base-tools.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/base-tools/base-tools.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,520 @@
+;;+-----------------------------------------------------------------------------
+;;+  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 :base-tools
+  (:use :cl)
+  (:nicknames :tools)
+  (:export :push-string
+	   :concat
+	   :when-do
+	   :string-replace
+	   :remove-null
+	   :full-path
+	   :trim-whitespace-left
+	   :trim-whitespace-right
+	   :trim-whitespace
+	   :string-starts-with
+	   :string-ends-with
+	   :string-ends-with-one-of
+	   :string-starts-with-char
+	   :string-starts-with-one-of
+	   :string-until
+	   :string-after
+	   :search-first
+	   :search-first-ignore-literals
+	   :concatenate-uri
+	   :absolute-uri-p
+	   :string-starts-with-digit
+	   :string-after-number
+	   :separate-leading-digits
+	   :white-space
+	   :white-space-p
+	   :escape-string
+	   :search-first-unclosed-paranthesis 
+	   :search-first-unopened-paranthesis
+	   :in-literal-string-p
+	   :find-literal-end
+	   :get-literal-quotation
+	   :get-literal
+	   :return-if-starts-with))
+
+(in-package :base-tools)
+
+
+(defparameter *white-space*
+  (list #\Space #\Tab #\Newline (code-char 13))
+  "Contains all characters that are treated as white space.")
+
+
+(defun white-space()
+  "Returns a lit os string that represents a white space."
+  (map 'list #'(lambda(char)
+		 (string char))
+       *white-space*))
+
+
+(defmacro concat (&rest strings)
+  `(concatenate 'string , at strings))
+
+
+(defmacro push-string (obj place)
+  "Imitates the push macro but instead of pushing object in a list,
+   there will be appended the given string to the main string object."
+  `(setf ,place (concat ,place ,obj)))
+
+
+(defmacro when-do (result-bounding condition-statement do-with-result)
+  "Executes the first statement and stores its result in the variable result.
+   If result isn't nil the second statement is called.
+   The second statement can use the variable tools:result as a parameter."
+  `(let ((,result-bounding ,condition-statement))
+     (if ,result-bounding
+	 ,do-with-result
+	 nil)))
+
+
+(defun white-space-p (str)
+  "Returns t if the passed str contains only white space characters."
+  (cond ((and (= (length str) 1)
+	      (string-starts-with-one-of str (white-space)))
+	 t)
+	((string-starts-with-one-of str (white-space))
+	 (white-space-p (subseq str 1)))
+	(t
+	 nil)))
+
+
+(defun remove-null (lst)
+  "Removes all null values from the passed list."
+  (remove-if #'null lst))
+
+
+(defun full-path (pathname)
+  "Returns a string that represents the full path of the passed
+   CL:Pathname construct."
+  (declare (CL:Pathname pathname))
+  (let ((segments
+	 (remove-if #'null
+		    (map 'list #'(lambda(item)
+				   (when (stringp item)
+				     (concat "/" item)))
+			 (pathname-directory pathname))))
+	(full-path-string ""))
+    (dolist (segment segments)
+      (push-string segment full-path-string))
+    (concat full-path-string "/" (pathname-name pathname))))
+
+
+(defun trim-whitespace-left (value)
+  "Uses string-left-trim with a predefined character-list."
+  (declare (String value))
+  (string-left-trim *white-space* value))
+
+
+(defun trim-whitespace-right (value)
+  "Uses string-right-trim with a predefined character-list."
+  (declare (String value))
+  (string-right-trim *white-space* value))
+
+
+(defun trim-whitespace (value)
+  "Uses string-trim with a predefined character-list."
+  (declare (String value))
+  (string-trim *white-space* value))
+
+
+(defun string-starts-with (str prefix &key (ignore-case nil))
+  "Checks if string str starts with a given prefix."
+  (declare (String str prefix)
+	   (Boolean ignore-case))
+  (let ((str-i (if ignore-case
+		   (string-downcase str :start 0 :end (min (length str)
+							   (length prefix)))
+		   str))
+	(prefix-i (if ignore-case
+		      (string-downcase prefix)
+		      prefix)))
+    (string= str-i prefix-i :start1 0 :end1
+	     (min (length prefix-i)
+		  (length str-i)))))
+
+
+(defun string-starts-with-one-of (str prefixes &key (ignore-case nil))
+  "Returns t if str ends with one of the string contained in suffixes."
+  (declare (String str)
+	   (List prefixes)
+	   (Boolean ignore-case))
+  (loop for prefix in prefixes
+     when (string-starts-with str prefix :ignore-case ignore-case)
+     return t))
+
+
+(defun string-ends-with (str suffix &key (ignore-case nil))
+  "Checks if string str ends with a given suffix."
+  (declare (String str suffix)
+	   (Boolean ignore-case))
+  (let ((str-i (if ignore-case
+		   (string-downcase str :start (max (- (length str)
+						       (length suffix))
+						    0)
+				    :end (length str))
+		   str))
+	(suffix-i (if ignore-case
+		      (string-downcase suffix)
+		      suffix)))
+    (string= str-i suffix-i :start1 (max (- (length str)
+					    (length suffix))
+					 0))))
+
+
+(defun string-ends-with-one-of (str suffixes &key (ignore-case nil))
+  "Returns t if str ends with one of the string contained in suffixes."
+  (declare (String str)
+	   (List suffixes)
+	   (Boolean ignore-case))
+  (loop for suffix in suffixes
+     when (string-ends-with str suffix :ignore-case ignore-case)
+     return t))
+
+
+(defun string-replace (main-string string-to-replace new-string)
+  "Replaces every occurrence of string-to-replace by new-string
+   in main-string."
+  (declare (String main-string string-to-replace new-string))
+  (if (string= string-to-replace new-string)
+      main-string
+      (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))))))
+
+
+
+(defun string-starts-with-digit (str)
+  "Checks whether the passed string starts with a digit."
+  (declare (String str))
+  (loop for item in (list 0 1 2 3 4 5 6 7 8 9)
+     when (string-starts-with str (write-to-string item))
+     return t))
+
+
+(defun string-after-number (str)
+  "If str starts with a digit, there is returned the first
+   substring after a character that is a non-digit.
+   If str does not start with a digit str is returned."
+  (declare (String str))
+  (if (and (string-starts-with-digit str)
+	   (> (length str) 0))
+      (string-after-number (subseq str 1))
+      str))
+
+
+(defun separate-leading-digits (str &optional digits)
+  "If str starts with a number the number is returned."
+  (declare (String str)
+	   (type (or Null String) digits))
+  (if (string-starts-with-digit str)
+      (separate-leading-digits
+       (subseq str 1) (concat digits (subseq str 0 1)))
+      digits))
+
+
+(defun string-starts-with-char (begin str)
+  (equal (char str 0) begin))
+
+
+(defun string-until (str anchor)
+  "Returns a substring until the position of the passed anchor."
+  (declare (String str anchor))
+  (let ((pos (search anchor str)))
+    (if pos
+	(subseq str 0 pos)
+	str)))
+
+
+(defun string-after (str prefix)
+  "Returns the substring after the found prefix.
+   If there is no substring equal to prefix nil is returned."
+  (declare (String str prefix))
+  (let ((pos (search prefix str)))
+    (if pos
+	(subseq str (+ pos (length prefix)))
+	nil)))
+
+
+(defun search-first (search-strings main-string &key from-end)
+  "Returns the position of one of the search-strings. The returned position
+   is the one closest to 0. If no search-string is found, nil is returned."
+  (declare (String main-string)
+	   (List search-strings))
+  (let ((positions
+	 (remove-null
+	  (map 'list #'(lambda(search-str)
+			 (search search-str main-string :from-end from-end))
+	       search-strings))))
+    (let ((sorted-positions (if from-end
+				(sort positions #'>)
+				(sort positions #'<))))
+      (when sorted-positions
+	(first sorted-positions)))))
+
+
+(defun find-literal-end (query-string delimiter &optional (overall-pos 0))
+  "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 '''.
+   If the returns value is nil, there is no closing delimiter."
+  (declare (String query-string delimiter)
+	   (Integer overall-pos))
+  (let ((current-pos (search delimiter query-string)))
+    (if current-pos
+	(if (string-ends-with (subseq query-string 0 current-pos) "\\")
+	    (find-literal-end (subseq query-string (+ current-pos
+						      (length delimiter)))
+			      delimiter (+ overall-pos current-pos 1))
+	    (+ overall-pos current-pos (length delimiter)))
+	nil)))
+
+
+(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 "'")
+	 "'")
+	((string-starts-with str "\"")
+	 "\"")))
+
+
+(defun get-literal (query-string &key (quotation nil))
+  "Returns a list of the form (:next-string <string> :literal <string>
+   where next-query is the query after the found literal and literal
+   is the literal string."
+  (declare (String query-string)
+	   (type (or Null String) quotation))
+  (let ((local-quotation quotation))
+    (cond ((or (string-starts-with query-string "\"\"\"")
+	       (string-starts-with query-string "'''"))
+	   (unless local-quotation
+	     (setf local-quotation (subseq query-string 0 3)))
+	   (let ((literal-end
+		  (find-literal-end (subseq query-string 3) (subseq query-string 0 3))))
+	     (when literal-end
+	       (list :next-string (subseq query-string (+ 3 literal-end))
+		     :literal (concat quotation
+				      (subseq query-string 3 literal-end)
+				      quotation)))))
+	  ((or (string-starts-with query-string "\"")
+	       (string-starts-with query-string "'"))
+	   (unless local-quotation
+	     (setf local-quotation (subseq query-string 0 1)))
+	   (let ((literal-end
+		  (find-literal-end (subseq query-string 1)
+				    (subseq query-string 0 1))))
+	     (when literal-end
+	       (let ((literal
+		      (escape-string (subseq query-string 1 literal-end) "\"")))
+		 (list :next-string (subseq query-string (+ 1 literal-end))
+		       :literal (concat local-quotation literal
+					local-quotation)))))))))
+
+
+(defun search-first-ignore-literals (search-strings main-string &key from-end)
+  (declare (String main-string)
+	   (List search-strings)
+	   (Boolean from-end))
+  (let ((first-pos
+	 (search-first search-strings main-string :from-end from-end)))
+    (when first-pos
+      (if (not (in-literal-string-p main-string first-pos))
+	  first-pos
+	  (let* ((literal-start
+		  (search-first (list "\"" "'") (subseq main-string 0 first-pos)
+				:from-end from-end))
+		 (next-str
+		  (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)))))
+	    (let ((next-pos
+		   (search-first-ignore-literals search-strings next-str
+						 :from-end from-end)))
+	      (when next-pos
+		(+ (- (length main-string) (length next-str)) next-pos))))))))
+
+
+(defun concatenate-uri (absolute-ns value)
+  "Returns a string conctenated of the absolut namespace an the given value
+   separated by either '#' or '/'."
+  (declare (string absolute-ns value))
+  (unless (and (> (length absolute-ns) 0)
+	       (> (length value) 0))
+    (error "From concatenate-uri(): absolute-ns and value must be of length > 0"))
+  (unless (absolute-uri-p absolute-ns)
+    (error "From concatenate-uri(): absolute-ns has to be an absolute URI: ~a" absolute-ns))
+  (let ((last-char
+	 (elt absolute-ns (- (length absolute-ns) 1)))
+	(first-char
+	 (elt value 0)))
+    (let ((separator
+	   (cond
+	     ((or (eql first-char #\#)
+		  (eql first-char #\/))
+	      "")
+	     ((or (eql last-char #\#)
+		  (eql last-char #\/))
+	      "")
+	     (t
+	      "/"))))
+      (let ((prep-ns
+	     (if (and (eql last-char first-char)
+		      (or (eql last-char #\#)
+			  (eql last-char #\/)))
+		 (subseq absolute-ns 0 (- (length absolute-ns) 1))
+		 (if (and (eql last-char #\#)
+			  (find #\/ value))
+		     (progn
+		       (when (not (eql first-char #\/))
+			 (setf separator "/"))
+		       (subseq absolute-ns 0 (- (length absolute-ns) 1)))
+		     absolute-ns))))
+	(concat prep-ns separator value)))))
+
+
+(defun absolute-uri-p (uri)
+  "Returns t if the passed uri is an absolute one. This
+   is indicated by a ':' with no leadgin '/'."
+  (when uri
+    (let ((position-of-colon
+	   (position #\: uri)))
+      (declare (string uri))
+      (and position-of-colon (> position-of-colon 0)
+	   (not (find #\/ (subseq uri 0 position-of-colon)))))))
+
+
+(defun escape-string (str char-to-escape)
+  "Escapes every occurrence of char-to-escape in str, if it is
+   not escaped."
+  (declare (String str char-to-escape))
+  (let ((result ""))
+    (dotimes (idx (length str))
+      (let ((current-char (subseq str idx (1+ idx)))
+	    (previous-char (if (= idx 0) "" (subseq str (1- idx) idx))))
+	(cond ((and (string= current-char char-to-escape)
+		    (string/= previous-char "\\"))
+	       (push-string "\\" result)
+	       (push-string current-char result))
+	      (t
+	       (push-string current-char result)))))
+    result))
+
+
+(defun in-literal-string-p(filter-string pos)
+  "Returns t if the passed pos is within a literal string value."
+  (declare (String filter-string)
+	   (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)))))))))
+
+
+(defun search-first-unclosed-paranthesis (str &key ignore-literals)
+  "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
+   \", \"\"\", ' and ''' are ignored."
+  (declare (String str)
+	   (Boolean ignore-literals))
+  (let ((open-brackets 0)
+	(result-idx nil))
+    (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)))
+		 (decf open-brackets)))
+	      ((string= current-char "(")
+	       (when (or ignore-literals
+			 (not (in-literal-string-p str idx)))
+		 (incf open-brackets)
+		 (when (> open-brackets 0)
+		   (setf result-idx idx)
+		   (setf idx 0)))))
+	(decf idx)))
+    result-idx))
+
+
+(defun search-first-unopened-paranthesis (str &key ignore-literals)
+  "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."
+  (declare (String str)
+	   (Boolean ignore-literals))
+  (let ((closed-brackets 0)
+	(result-idx nil))
+    (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)))
+		 (decf closed-brackets)
+		 (setf result-idx nil)))
+	      ((string= current-char ")")
+	       (when (or ignore-literals
+			 (not (in-literal-string-p str idx)))
+		 (incf closed-brackets)
+		 (when (> closed-brackets 0)
+		   (setf result-idx idx)
+		   (setf idx (length str))))))))
+    result-idx))
+
+
+(defun return-if-starts-with (str to-be-matched &key from-end ignore-case
+			      ignore-leading-whitespace)
+  "Returns the string that is contained in to-be-matched and that is the
+   start of the string str."
+  (declare (String str)
+	   (List to-be-matched)
+	   (Boolean from-end ignore-case ignore-leading-whitespace))
+  (let ((cleaned-str (if ignore-leading-whitespace
+			 (trim-whitespace-left str)
+			 str)))
+    (loop for try in to-be-matched
+       when (if from-end
+		(string-ends-with cleaned-str try :ignore-case ignore-case)
+		(string-starts-with cleaned-str try :ignore-case ignore-case))
+       return try)))
\ No newline at end of file

Added: trunk/playground/abcl-test/lisp-code/test-code/functions.lisp
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/lisp-code/test-code/functions.lisp	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,11 @@
+(defun print-line(param)
+	(format t "~a~%" param))
+	
+	
+(defun add(a b)
+	(+ a b))
+	
+
+
+(let ((line-str (concatenate 'string "the result of 6 + 2 is " (write-to-string (add 6 2)))))
+	(print-line line-str))
\ No newline at end of file

Added: trunk/playground/abcl-test/src/program/Main.java
==============================================================================
--- (empty file)
+++ trunk/playground/abcl-test/src/program/Main.java	Wed Feb 16 04:51:06 2011
@@ -0,0 +1,75 @@
+package program;
+
+import org.armedbear.lisp.Cons;
+import org.armedbear.lisp.Fixnum;
+import org.armedbear.lisp.Function;
+import org.armedbear.lisp.Interpreter;
+import org.armedbear.lisp.JavaObject;
+import org.armedbear.lisp.LispObject;
+import org.armedbear.lisp.MacroObject;
+import org.armedbear.lisp.Packages;
+import org.armedbear.lisp.Package;
+import org.armedbear.lisp.Symbol;
+
+
+
+public class Main {
+	public static void main(String[] args){
+		//testABCL();
+		loadTmSparql();
+	}
+	
+	
+	public static void testABCL(){
+		// load the file functions.lisp which also evaluates a let as last command 
+		Interpreter interpreter = Interpreter.createInstance();
+		interpreter.eval("(load \"lisp-code/test-code/functions.lisp\")");
+
+		
+		// use the lisp function print-line
+		Package defaultPackage = Packages.findPackage("CL-USER");
+		Symbol myFunctionSym = defaultPackage.findAccessibleSymbol("PRINT-LINE");
+		Function printLineFun = (Function)myFunctionSym.getSymbolFunction();
+		LispObject lispString = JavaObject.getInstance("This is a java string", true);
+		printLineFun.execute(lispString);
+		
+		
+		// use the lisp function add
+		myFunctionSym = defaultPackage.findAccessibleSymbol("ADD");
+		Function addFun = (Function)myFunctionSym.getSymbolFunction();
+		LispObject lispInt1 = JavaObject.getInstance(6, true);
+		LispObject lispInt2 = JavaObject.getInstance(2, true);
+		LispObject result = addFun.execute(lispInt1, lispInt2);
+		System.out.println(result.intValue());
+
+		
+		// use the build-i function cons
+		myFunctionSym = defaultPackage.findAccessibleSymbol("CONS");
+		Function consFun = (Function)myFunctionSym.getSymbolFunction();
+		Cons list = (Cons) consFun.execute(Fixnum.getInstance(64), Fixnum.getInstance(65));
+		System.out.println(list.car.intValue() + ", " + list.cdr.intValue());
+	}
+	
+	
+	public static void loadTmSparql(){
+		// === load base-tools.lisp ===========================================
+		Interpreter interpreter = Interpreter.createInstance();
+		interpreter.eval("(load \"lisp-code/base-tools/base-tools.lisp\")");
+		
+		
+		// === load sparql.lisp ===============================================
+		//interpreter.eval("(load \"lisp-code/TM-SPARQL/sparql.lisp\")");
+		//TODO: import datamodel => implement an abstract datamodel
+		
+		
+		// === test the loaded files ==========================================
+		Package defaultPackage = Packages.findPackage("BASE-TOOLS");
+		Symbol myFunSym = defaultPackage.findAccessibleSymbol("separate-leading-digits".toUpperCase());
+		Function strFun = (Function)myFunSym.getSymbolFunction();
+		
+		LispObject str1 = JavaObject.getInstance("no leading digits in this string", true);
+		LispObject str2 = JavaObject.getInstance("123 string started with 3 digits", true);
+		System.out.println(strFun.execute(str1));
+		System.out.println(strFun.execute(str2));
+	}
+}

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	Wed Feb 16 04:51:06 2011
@@ -11,13 +11,13 @@
 (in-package :TM-SPARQL)
 
 
-;TODO: create a macro for "filter-for-scopes", "filter-for-reifier", ...
-
-
-(defmacro with-triple-nodes (construct &body body)
-  `(let* ((subj (subject ,construct))
-	  (pred (predicate ,construct))
-	  (obj (object ,construct))
+(defmacro with-triple-nodes (triple-construct &body body)
+  "Generates the variables subj, pred, obj that references the triple's
+   nodes. Additionaly the variables subj-uri, pred-uri and obj-uri are
+   generated when the corresponding node is a resource-nodes."
+  `(let* ((subj (subject ,triple-construct))
+	  (pred (predicate ,triple-construct))
+	  (obj (object ,triple-construct))
 	  (subj-uri (unless (variable-p subj)
 		      (sparql-node (value subj) :revision revision)))
 	  (pred-uri (unless (variable-p pred)




More information about the Isidorus-cvs mailing list