[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