Author: lgiessmann Date: Tue Dec 21 17:57:57 2010 New Revision: 383 Log: TM-SPARQL: fixed a fundamental bug => if a filter uses more than one variable from different triples => currently there is created a cross product of all variable-results in a select-group, afterwards the values that always evaluates to false are removed from the main result. Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Tue Dec 21 17:57:57 2010 @@ -129,11 +129,12 @@ (defun filter-functions::regex(str pattern &optional flags) - (let* ((local-flags (filter-functions::normalize-value 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 + (local-pattern (if (find #\x local-flags) (base-tools:string-replace (base-tools:string-replace @@ -148,7 +149,7 @@ :case-insensitive-mode case-insensitive :multi-line-mode multi-line :single-line-mode single-line))) - (ppcre:scan scanner str))) + (ppcre:scan scanner local-str))) (defun filter-functions::bound(x) Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Tue Dec 21 17:57:57 2010 @@ -234,12 +234,10 @@ value is nil.") (:method ((construct SPARQL-query) (string-with-prefix String)) (loop for entry in (prefixes construct) - when (string-starts-with string-with-prefix - (concatenate 'string (getf entry :label) ":")) + when (string-starts-with string-with-prefix (concat (getf entry :label) ":")) return (concatenate-uri (getf entry :value) - (string-after string-with-prefix - (concatenate 'string (getf entry :label) ":")))))) + (string-after string-with-prefix (concat (getf entry :label) ":")))))) (defgeneric add-variable (construct variable-name) @@ -252,61 +250,173 @@ (push variable-name (variables construct))))) -(defgeneric generate-let-variable-string (construct value) - (:documentation "Returns a list if the form (:string <var-string> - :variable-names (<?var-name-as-string> - <$var-name-as-string>)).") - (:method ((construct SPARQL-Triple-Elem) value) - (when (variable-p construct) - (let* ((var-value (write-to-string value)) - (var-name (value construct)) - (lisp-str - (concatenate 'string "(?" var-name " " var-value ")" - "($" var-name " " var-value ")")) - (vars - (concatenate 'string "?" var-name " $" var-name))) - (list :string lisp-str - :variable-names vars))))) - - -(defgeneric invoke-filter (construct filter-string) - (:documentation "Invokes the passed filter on the construct that - represents a sparql result.") - (:method ((construct SPARQL-Triple) (filter-string String)) - (let ((results nil)) ;a list of the form (:subject x :predicate y :object z) - (dotimes (row-idx (length (subject-result construct))) - (let* ((subj-elem - (generate-let-variable-string - (subject construct) (elt (subject-result construct) row-idx))) - (pred-elem - (generate-let-variable-string - (predicate construct) (elt (predicate-result construct) row-idx))) - (obj-elem - (generate-let-variable-string - (object construct) (elt (object-result construct) row-idx))) - (expression - (concatenate 'string - "(let* ((true t)(false nil)" - (getf subj-elem :string) - (getf pred-elem :string) - (getf obj-elem :string) - "(result " filter-string "))" - "(declare (ignorable true false " - (getf subj-elem :variable-names) " " - (getf pred-elem :variable-names) " " - (getf obj-elem :variable-names) "))" - "result)"))) - (when (eval (read-from-string expression)) - (push (list :subject (elt (subject-result construct) row-idx) - :predicate (elt (predicate-result construct) row-idx) - :object (elt (object-result construct) row-idx)) - results)))) - (setf (subject-result construct) - (map 'list #'(lambda(result) (getf result :subject)) results)) - (setf (predicate-result construct) - (map 'list #'(lambda(result) (getf result :predicate)) results)) - (setf (object-result construct) - (map 'list #'(lambda(result) (getf result :object)) results))))) +(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) @@ -333,7 +443,7 @@ "Returns '<'uri-string'>' if uri-string is not a string uri-string is returned as result." (if (typep uri-string 'String) - (concatenate 'string "<" uri-string ">") + (concat "<" uri-string ">") uri-string)) @@ -884,7 +994,7 @@ (defmethod all-variables ((construct SPARQL-Query)) - "Returns all variables that are contained in the select groupt memebers." + "Returns all variables that are contained in the select group memebers." (remove-duplicates (remove-null (loop for triple in (select-group construct) @@ -1054,7 +1164,8 @@ ;; filters all entries that are not important for the result ;; => an intersection is invoked (reduce-results construct (make-result-lists construct)) - (dolist (triple (select-group construct)) - (dolist (filter (filters construct)) - (invoke-filter triple filter))) +; (dolist (triple (select-group construct)) +; (dolist (filter (filters construct)) +; (invoke-filter triple construct filter))) + (process-filters construct) construct) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Tue Dec 21 17:57:57 2010 @@ -571,6 +571,7 @@ (when inner-value (+ inner-value (1+ (length (name-after-paranthesis (subseq left-string inner-value)))))))) + (start-idx (if first-bracket first-bracket 0))) @@ -949,4 +950,28 @@ t)) (if (find string-before *supported-functions* :test #'string=) nil - t)))) \ No newline at end of file + 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 Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Dec 21 17:57:57 2010 @@ -38,7 +38,8 @@ :test-set-+-and---operators :test-set-compare-operators :test-set-functions - :test-module-1)) + :test-module-1 + :test-module-2)) (in-package :sparql-test) @@ -1599,6 +1600,32 @@ (list "Johann Wolfgang" "von Goethe" "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") :test #'string=)))))))) + + +(test test-module-2 + "Tests the entire module." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 + "PREFIX poem:<http://some.where/psis/poem/> + PREFIX author:<http://some.where/psis/author/> + PREFIX main:<http://some.where/base-psis/> + PREFIX tmdm:<http://psi.topicmaps.org/iso13250/model/> + SELECT ?poems WHERE{ + ?poems tmdm:type main:poem . #self as ?x a <y> + ?poems main:title ?titles . + FILTER (REGEX(?titles, '[a-zA-Z]+ [a-zA-Z]+')) }") + (result-1 + (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)))) + (is-true result-1) + (is (= (length result-1) 1)) + (is (string= (getf (first result-1) :variable) "poems")) + (is-false (set-exclusive-or + (getf (first result-1) :result) + (list "<http://some.where/psis/poem/resignation>" + "<http://some.where/psis/poem/erlkoenig>" + "<http://some.where/psis/poem/zauberlehrling>") + :test #'string=)))))) (defun run-sparql-tests ()