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)) + ,@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 ,@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)