isidorus-cvs

isidorus-cvs@common-lisp.net

1037 discussions

[isidorus-cvs] r424 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 07 Apr '11

07 Apr '11

Author: lgiessmann Date: Thu Apr 7 07:23:13 2011 New Revision: 424 Log: TM-SPARQL: fixed a bug with the FILTER function BOUND; fixed also a performance problem when using defvar in functions, so now defvar is replaced by let followed by a (declare (Special <vars>)) command Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Thu Apr 7 07:23:13 2011 @@ -368,6 +368,38 @@ (elt (getf results :result) idx))))))))) +;(defun to-lisp-code (variable-values filter) +; "Concatenates all variable names and elements with the filter expression +; in a let statement and returns a string representing the corresponding +; lisp code." +; (declare (List variable-values)) +; (let ((result "") +; (cleanup-str "")) +; (dolist (var-elem variable-values) +; (push-string +; (concat "(defvar ?" (getf var-elem :variable-name) " " +; (write-to-string (getf var-elem :variable-value)) ")") +; result) +; (push-string +; (concat "(defvar $" (getf var-elem :variable-name) " " +; (write-to-string (getf var-elem :variable-value)) ")") +; result)) +; (push-string "(let* ((true t)(false nil)" result) +; (push-string (concat "(result " filter "))") result) +; (push-string "(declare (Ignorable true false " result) +; (push-string "))" result) +; (dolist (var-elem variable-values) +; (push-string (concat "(makunbound '?" (getf var-elem :variable-name) ")") +; cleanup-str) +; (push-string (concat "(makunbound '$" (getf var-elem :variable-name) ")") +; cleanup-str)) +; (push-string "(in-package :cl-user)" cleanup-str) +; (push-string cleanup-str result) +; (push-string "result)" result) +; (concat "(handler-case (progn " result ") (condition () (progn " cleanup-str +; "nil)))"))) + + (defun to-lisp-code (variable-values filter) "Concatenates all variable names and elements with the filter expression in a let statement and returns a string representing the corresponding @@ -386,6 +418,12 @@ (when variable-values (dolist (var-elem variable-values) (push-string (concat "?" (getf var-elem :variable-name) " ") result) + (push-string (concat "$" (getf var-elem :variable-name) " ") result)) + (push-string ")" result)) + (when variable-values + (push-string "(Special " result) + (dolist (var-elem variable-values) + (push-string (concat "?" (getf var-elem :variable-name) " ") result) (push-string (concat "$" (getf var-elem :variable-name) " ") result))) (push-string ")) result)" result) (concat "(handler-case " result " (condition () nil))"))) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Thu Apr 7 07:23:13 2011 @@ -235,10 +235,14 @@ (let* ((var-start (search-first (list "?" "$") cleaned-arg-list)) (var-end - (when var-start - (search-first - (list ")") - (subseq cleaned-arg-list var-start))))) + (let ((val + (when var-start + (search-first + (list ")") + (subseq cleaned-arg-list var-start))))) + (if val + val + (length (subseq cleaned-arg-list var-start)))))) (when (and var-start var-end) (concat (subseq cleaned-arg-list 0 var-start) "\"" (subseq cleaned-arg-list var-start Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Thu Apr 7 07:23:13 2011 @@ -2407,7 +2407,8 @@ <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82 FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1 - FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'" + FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe' + FILTER BOUND(?obj1) && !BOUND(?obj2) && BOUND(?pred1)" "}")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) ;(is-true (= (length r-1) 2))

1 0

[isidorus-cvs] r423 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 07 Apr '11

07 Apr '11

Author: lgiessmann Date: Thu Apr 7 05:22:22 2011 New Revision: 423 Log: TM-SPARQL: fixed another efficiency problem in the processing of filters Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Thu Apr 7 05:22:22 2011 @@ -152,8 +152,12 @@ (ppcre:scan scanner local-str))) +(defun filter-functions::write-to-symbol (name-string) + (common-lisp:intern (common-lisp:string-upcase name-string))) + + (defun filter-functions::bound(x) - (boundp x)) + (boundp (filter-functions::write-to-symbol x))) (defun filter-functions::isLITERAL(x) Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Thu Apr 7 05:22:22 2011 @@ -394,14 +394,22 @@ (defun return-false-values (all-values true-values) "Returns a list that contains all values from all-values that are not contained in true-values." - (let ((local-all-values - (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values) - :test #'variable-list=)) - (results nil)) - (dolist (value local-all-values) - (when (not (find value true-values :test #'variable-list=)) - (push value results))) - results)) + (cond ((not all-values) + nil) + ((not true-values) + (let ((local-all-values + (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values) + :test #'variable-list=))) + local-all-values)) + (t + (let ((local-all-values + (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values) + :test #'variable-list=)) + (results nil)) + (dolist (value local-all-values) + (when (not (find value true-values :test #'variable-list=)) + (push value results))) + results)))) (defun variable-list= (x y) @@ -413,15 +421,16 @@ (defgeneric process-filters (construct) (:documentation "Processes all filters by calling invoke-filter.") - (:method ((construct SPARQL-Query)) + (:method ((construct SPARQL-Query)) (dolist (filter (filters construct)) - (let* ((filter-variable-names - (get-variables-from-filter-string filter)) - (filter-variable-values nil)) + (let ((filter-variable-names (get-variables-from-filter-string filter)) + (filter-variable-values nil)) (dolist (var-name filter-variable-names) (setf filter-variable-values (make-variable-values construct var-name filter-variable-values))) (setf filter-variable-values + (remove-duplicates-from-variable-list construct filter-variable-values)) + (setf filter-variable-values (cast-variable-values construct filter-variable-values)) (let ((true-values nil)) (dolist (var-elem filter-variable-values) @@ -435,8 +444,41 @@ :test #'variable-list=)))) (dolist (to-del values-to-remove) (delete-rows-by-value construct (getf to-del :variable-name) - (getf to-del :variable-value))))))) - construct)) + (getf to-del :variable-value))))))))) + + +(defgeneric remove-duplicates-from-variable-list (construct variable-list) + (:documentation "Removes all duplicates from the passed variable list") + (:method ((construct SPARQL-QUERY) (variable-list LIST)) + (remove-duplicates + variable-list + :test #'(lambda(x y) + (when (= (length x) (length y)) + (let ((result nil)) + (dotimes (idx (length x) result) + (let ((cx (elt x idx)) + (cy (elt y idx))) + (when (or (string/= (getf cx :variable-name) + (getf cy :variable-name)) + (and (getf cx :literal-datatype) + (getf cy :literal-datatype) + (string/= (getf cx :literal-datatype) + (getf cy :literal-datatype))) + (and (getf cx :literal-datatype) + (not (getf cy :literal-datatype))) + (and (not (getf cx :literal-datatype)) + (getf cy :literal-datatype)) + (and (getf cx :variable-value) + (getf cy :variable-value) + (string/= (getf cx :variable-value) + (getf cy :variable-value))) + (and (getf cx :variable-value) + (not (getf cy :variable-value))) + (and (not (getf cx :variable-value)) + (getf cy :variable-value))) + (setf idx (length x)))) + (when (= idx (max 0 (1- (length x)))) + (setf result t))))))))) (defgeneric idx-of (construct variable-name variable-value &key what) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Thu Apr 7 05:22:22 2011 @@ -230,11 +230,27 @@ (arg-list (bracket-scope cleaned-right-str)) (cleaned-arg-list (clean-function-arguments arg-list)) (modified-str - (concat - left-str "(" fun-name " " cleaned-arg-list ")" - (subseq right-str (+ (- (length right-str) - (length cleaned-right-str)) - (length arg-list)))))) + (let ((modified-arg-list + (if (string= fun-name "BOUND") + (let* ((var-start + (search-first (list "?" "$") cleaned-arg-list)) + (var-end + (when var-start + (search-first + (list ")") + (subseq cleaned-arg-list var-start))))) + (when (and var-start var-end) + (concat (subseq cleaned-arg-list 0 var-start) + "\"" (subseq cleaned-arg-list var-start + (+ var-start var-end)) + "\"" (subseq cleaned-arg-list + (+ var-start var-end))))) + cleaned-arg-list))) + (concat + left-str "(" fun-name " " modified-arg-list ")" + (subseq right-str (+ (- (length right-str) + (length cleaned-right-str)) + (length arg-list))))))) (set-functions construct modified-str)))))) @@ -1000,20 +1016,33 @@ (let ((variables nil)) (dotimes (idx (length filter-string)) (let ((current-string (subseq filter-string idx))) - (when (and (or (string-starts-with current-string "?") - (string-starts-with current-string "$")) - (not (in-literal-string-p filter-string idx))) - (let ((end-pos - (let ((inner-value - (search-first - (append (list " " "?" "$" "." ",") - (*supported-operators*) - *supported-brackets* - (map 'list #'string (white-space))) - (subseq current-string 1)))) - (if inner-value - (1+ inner-value) - (length current-string))))) - (push (subseq current-string 1 end-pos) variables) - (incf idx end-pos))))) + (cond ((and (or (string-starts-with current-string "?") + (string-starts-with current-string "$")) + (not (in-literal-string-p filter-string idx))) + (let ((end-pos + (let ((inner-value + (search-first + (append (list " " "?" "$" "." ",") + (*supported-operators*) + *supported-brackets* + (map 'list #'string (white-space))) + (subseq current-string 1)))) + (if inner-value + (1+ inner-value) + (length current-string))))) + (push (subseq current-string 1 end-pos) variables) + (incf idx end-pos))) + ;BOUND needs a separate hanlding since all variables + ; were written into strings so they have to be + ; searched different + ((and (string-starts-with current-string "BOUND ") + (not (in-literal-string-p filter-string idx))) + (let* ((next-str (subseq current-string (length "BOUND "))) + (literal (when (string-starts-with next-str "\"") + (let ((val (get-literal next-str))) + (when val + (getf val :literal)))))) + (when (and literal (> (length literal) 3)) ;"?.." | "$.." + (push (subseq (string-trim (list #\") literal) 1) variables)) + (incf idx (+ (length "BOUND ") (length literal)))))))) (remove-duplicates variables :test #'string=))) \ No newline at end of file Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Thu Apr 7 05:22:22 2011 @@ -1530,7 +1530,7 @@ (is-true result-5) (is-true result-5-2) (is-true result-5-3) (is-true result-5-4) (is-true result-5-5) (is-true result-5-6) (is (string= (string-replace result-1-6 " " "") - "(or(progn(BOUND(progn(progn?var))))(progn(progn(and(progn(isLITERAL$var))(progn(=?var\"abc\"))))))")) + "(or(progn(BOUND(progn(progn\"?var\"))))(progn(progn(and(progn(isLITERAL$var))(progn(=?var\"abc\"))))))")) (is (string= (string-replace result-2-6 " " "") "(progn(or(progn(REGEX?var1\"\"?var3))(progn(progn(and(progn(>?var1?var3))(progn(progn(=(STR?var)\"abc\"))))))))")) (is (string= (string-replace result-3-6 " " "")

1 0

[isidorus-cvs] r422 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 06 Apr '11

06 Apr '11

Author: lgiessmann Date: Wed Apr 6 16:53:10 2011 New Revision: 422 Log: TM-SPARQL: fixed a bug when there is a greater amount of variables in filters contained in one select-group Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Apr 6 16:53:10 2011 @@ -413,7 +413,7 @@ (defgeneric process-filters (construct) (:documentation "Processes all filters by calling invoke-filter.") - (:method ((construct SPARQL-Query)) + (:method ((construct SPARQL-Query)) (dolist (filter (filters construct)) (let* ((filter-variable-names (get-variables-from-filter-string filter)) @@ -423,20 +423,19 @@ (make-variable-values construct var-name filter-variable-values))) (setf filter-variable-values (cast-variable-values construct filter-variable-values)) - (dolist (filter (filters construct)) - (let ((true-values nil)) - (dolist (var-elem filter-variable-values) - (when (eval (read-from-string (to-lisp-code var-elem filter))) - (map 'list #'(lambda(list-elem) - (push list-elem true-values)) - var-elem))) - (let ((values-to-remove - (return-false-values filter-variable-values - (remove-duplicates true-values - :test #'variable-list=)))) - (dolist (to-del values-to-remove) - (delete-rows-by-value construct (getf to-del :variable-name) - (getf to-del :variable-value)))))))) + (let ((true-values nil)) + (dolist (var-elem filter-variable-values) + (when (eval (read-from-string (to-lisp-code var-elem filter))) + (map 'list #'(lambda(list-elem) + (push list-elem true-values)) + var-elem))) + (let ((values-to-remove + (return-false-values filter-variable-values + (remove-duplicates true-values + :test #'variable-list=)))) + (dolist (to-del values-to-remove) + (delete-rows-by-value construct (getf to-del :variable-name) + (getf to-del :variable-value))))))) construct)) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Apr 6 16:53:10 2011 @@ -2406,7 +2406,8 @@ "SELECT * WHERE { <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82 - FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1" + FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1 + FILTER ?obj1 >= 82 || ?obj1 = 'von Goethe'" "}")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) ;(is-true (= (length r-1) 2))

1 0

[isidorus-cvs] r421 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 06 Apr '11

06 Apr '11

Author: lgiessmann Date: Wed Apr 6 12:14:13 2011 New Revision: 421 Log: TM-SPARQL: fixed an bug that influences the efficiency of the system, i.e. when there are more than one filter the system is getting slow Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Apr 6 12:14:13 2011 @@ -417,29 +417,26 @@ (dolist (filter (filters construct)) (let* ((filter-variable-names (get-variables-from-filter-string filter)) - (filter-variable-values nil) - (true-values nil)) + (filter-variable-values nil)) (dolist (var-name filter-variable-names) (setf filter-variable-values (make-variable-values construct var-name filter-variable-values))) (setf filter-variable-values (cast-variable-values construct filter-variable-values)) (dolist (filter (filters construct)) - (dolist (var-elem filter-variable-values) - - ;(format t "~%~%>>~a<<~%~%" (to-lisp-code var-elem filter)); TODO: remove - - (when (eval (read-from-string (to-lisp-code var-elem filter))) - (map 'list #'(lambda(list-elem) - (push list-elem true-values)) - var-elem)))) - (let ((values-to-remove - (return-false-values filter-variable-values - (remove-duplicates true-values - :test #'variable-list=)))) - (dolist (to-del values-to-remove) - (delete-rows-by-value construct (getf to-del :variable-name) - (getf to-del :variable-value)))))) + (let ((true-values nil)) + (dolist (var-elem filter-variable-values) + (when (eval (read-from-string (to-lisp-code var-elem filter))) + (map 'list #'(lambda(list-elem) + (push list-elem true-values)) + var-elem))) + (let ((values-to-remove + (return-false-values filter-variable-values + (remove-duplicates true-values + :test #'variable-list=)))) + (dolist (to-del values-to-remove) + (delete-rows-by-value construct (getf to-del :variable-name) + (getf to-del :variable-value)))))))) construct)) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Wed Apr 6 12:14:13 2011 @@ -39,7 +39,7 @@ (defparameter *allowed-filter-calls* - (append (list "one+" "one-" "progn" "or" "and" "not" "/=" "=" + (append (list "one+" "one-" "progn" "or" "and" "not" "!=" "=" ">" ">=" "<" "<=" "+" "-" "*" "/") *supported-functions*)) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Apr 6 12:14:13 2011 @@ -54,7 +54,8 @@ :test-module-13 :test-module-14 :test-module-15 - :test-module-16)) + :test-module-16 + :test-module-17)) (in-package :sparql-test) @@ -2397,10 +2398,21 @@ r-1)))) +(test test-module-17 + "Tests the entire module with the file sparql_test.xtm" + (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) + (tm-sparql:init-tm-sparql) + (let* ((q-1 (concat + "SELECT * WHERE { + <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. + FILTER isLITERAL(?obj1) && !isLITERAL(?pred1) && ?obj1 = 'von Goethe' || ?obj1 = 82 + FILTER ?pred1 = $pred1 && $obj1 = $obj1 && ?pred1 != ?obj1" + "}")) + (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) + ;(is-true (= (length r-1) 2)) + (format t "~a~%" r-1)))) -;TODO: test complex filters - (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

[isidorus-cvs] r420 - trunk/src/unit_tests
by Lukas Giessmann 06 Apr '11

06 Apr '11

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

1 0

[isidorus-cvs] r419 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 06 Apr '11

06 Apr '11

Author: lgiessmann Date: Wed Apr 6 11:02:36 2011 New Revision: 419 Log: TM-SPARQL: sparql filters now support constants of the form 'string-value'^^datatype and 'string'@lang Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/base-tools/base-tools.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Wed Apr 6 11:02:36 2011 @@ -177,7 +177,7 @@ (cond (type-suffix type-suffix) ((integerp x) constants::*xml-integer*) ((floatp x) constants::*xml-decimal*) - ((numberp x) constants::*xml-double*) + ((typep x 'double-float) constants::*xml-double*) ((stringp x) constants::*xml-string*) (t (type-of x))))) Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Apr 6 11:02:36 2011 @@ -426,20 +426,17 @@ (cast-variable-values construct filter-variable-values)) (dolist (filter (filters construct)) (dolist (var-elem filter-variable-values) - - ;(format t "~a~%==>~a~%~%" (to-lisp-code var-elem filter) - ;(eval (read-from-string (to-lisp-code var-elem filter)))) ;TODO: remove + + ;(format t "~%~%>>~a<<~%~%" (to-lisp-code var-elem filter)); TODO: remove (when (eval (read-from-string (to-lisp-code var-elem filter))) (map 'list #'(lambda(list-elem) (push list-elem true-values)) var-elem)))) - ;(format t "tv: -->~a<--~%" true-values) ;TODO: remove (let ((values-to-remove (return-false-values filter-variable-values (remove-duplicates true-values :test #'variable-list=)))) - ;(format t "vr: -->~a<--~%" values-to-remove) ;TODO: remove (dolist (to-del values-to-remove) (delete-rows-by-value construct (getf to-del :variable-name) (getf to-del :variable-value)))))) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Wed Apr 6 11:02:36 2011 @@ -106,8 +106,10 @@ (original-filter-string (subseq query-string 0 (- (length query-string) (length next-query)))) + (filter-string-casted-constants + (cast-literal-constants construct filter-string)) (filter-string-unary-ops - (set-unary-operators construct filter-string)) + (set-unary-operators construct filter-string-casted-constants)) (filter-string-or-and-ops (set-or-and-operators construct filter-string-unary-ops original-filter-string)) @@ -119,10 +121,57 @@ (set-functions construct filter-string-compare-ops))) (add-filter construct (scan-filter-for-deprecated-calls - construct filter-string-functions original-filter-string)) + construct filter-string-functions filter-string)) (parse-group construct next-query)))) +(defgeneric cast-literal-constants (construct filter-string) + (:documentation "Casts all constants of the form 'string-value'^^datatype to an + object of the specified type. If the specified type is not + supported the return value is the string-value without a + type specifier.") + (:method ((construct SPARQL-Query) (filter-string String)) + (let ((first-pos (search-first (list "'" "\"") filter-string))) + (if (not first-pos) + filter-string + (let* ((delimiters + (append (white-space) *supported-brackets* (list "}"))) + (result (get-literal (subseq filter-string first-pos))) + (literal-value (getf result :literal)) + (next-string (getf result :next-string)) + (lang + (when (string-starts-with next-string "@") + (let ((end-pos (search-first delimiters next-string))) + (when end-pos + (subseq next-string 0 end-pos))))) + (type + (when (string-starts-with next-string "^^") + (let ((end-pos + (let ((pos (search-first delimiters next-string))) + (if pos + pos + (length next-string))))) + (when end-pos + (subseq next-string 2 end-pos))))) + (modified-literal-value + (if type + (if (> (length literal-value) 0) + (string-trim (list (elt literal-value 0)) literal-value) + literal-value) + literal-value))) + (concat (subseq filter-string 0 first-pos) + (if type + (write-to-string + (cast-literal modified-literal-value type + :back-as-string-when-unsupported t)) + modified-literal-value) + (cast-literal-constants + construct + (subseq next-string (cond (lang (length lang)) + (type (+ 2 (length type))) + (t 0)))))))))) + + (defgeneric scan-filter-for-deprecated-calls (construct filter-string original-filter) (:documentation "Returns the passed filter-string where all functions @@ -695,7 +744,7 @@ (declare (String filter-string) (Integer idx)) (let* ((string-after (subseq filter-string (1+ idx))) - (cleaned-str (cut-comment string-after))) + (cleaned-str (trim-whitespace-left string-after))) (cond ((string-starts-with cleaned-str "(") (let ((result (bracket-scope cleaned-str))) (list :next-query (string-after cleaned-str result) @@ -741,14 +790,14 @@ that is the scope of the function, i.e. the function name and all its variable including the closing )." (declare (String str)) - (let* ((cleaned-str (cut-comment str)) + (let* ((cleaned-str (trim-whitespace-left str)) (after-fun (remove-null (map 'list #'(lambda(fun) (when (string-starts-with cleaned-str fun) (string-after str fun))) *supported-functions*))) (fun-suffix (when after-fun - (cut-comment (first after-fun))))) + (trim-whitespace-left (first after-fun))))) (when fun-suffix (let* ((args (bracket-scope fun-suffix)) (fun-name (string-until cleaned-str args))) @@ -864,11 +913,6 @@ (setf idx (- (1- (length query-string)) (length (getf result :next-string)))) (push-string (getf result :literal) filter-string))) - ((string= "#" current-char) - (let ((comment-string - (string-until (subseq query-string idx) - (string #\newline)))) - (setf idx (+ idx (length comment-string))))) ((and (string= current-char (string #\newline)) (= 0 open-brackets)) (setf result Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Wed Apr 6 11:02:36 2011 @@ -280,7 +280,7 @@ "Returns the end of the literal corresponding to the passed delimiter string. The query-string must start after the opening literal delimiter. The return value is an int that represents the start index of closing - delimiter. delimiter must be either \", ', or '''. + delimiter. delimiter must be either \", ', \"\"\", or '''. If the returns value is nil, there is no closing delimiter." (declare (String query-string delimiter) (Integer overall-pos)) @@ -297,7 +297,7 @@ (defun get-literal-quotation (str) "Returns ', ''', \" or \"\"\" when the string starts with a literal delimiter." (cond ((string-starts-with str "'''") - "'") + "'''") ((string-starts-with str "\"\"\"") "\"\"\"") ((string-starts-with str "'") Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Apr 6 11:02:36 2011 @@ -1546,9 +1546,9 @@ (with-revision 0 (let* ((query-1 "BASE <http://some.where/psis/poem/> - SELECT $subject ?predicate WHERE{ - ?subject $predicate <zauberlehrling> . - FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}") + SELECT $subject ?predicate WHERE{ + ?subject $predicate <zauberlehrling> . + FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}") (query-2 "SELECT ?object ?subject WHERE{ <http://some.where/psis/author/goethe> ?predicate ?object . FILTER (isLITERAL(?object) && @@ -2364,8 +2364,8 @@ (let* ((q-1 (concat "SELECT * WHERE { <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. - FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 - #FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'^^" *xml-integer* " + #FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 + FILTER ?obj1 = 'von Goethe'^^" *xml-string* " || ?obj1 = '82'^^" *xml-integer* " #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1) #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1) #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))" @@ -2373,17 +2373,6 @@ }")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) - - ;(map 'list #'(lambda(triple) - ;(format t "~a - ~a - ~a[~a]~%" - ;(tm-sparql::subject-result triple) - ;(tm-sparql::predicate-result triple) - ;(tm-sparql::object-result triple) - ;(tm-sparql::object-datatype triple))) - ;(tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))) - - - (is-true (= (length r-1) 2)) (map 'list #'(lambda(item) (cond @@ -2395,7 +2384,6 @@ (format t "~a~%" r-1)))) -;TODO: cast literal-values when called in filters ;TODO: test complex filters (defun run-sparql-tests ()

1 0

[isidorus-cvs] r418 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 06 Apr '11

06 Apr '11

Author: lgiessmann Date: Wed Apr 6 07:01:57 2011 New Revision: 418 Log: TM-SPARQL: filters use now the actual datatype, e.g. 82 instead of '82' ... Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Apr 6 07:01:57 2011 @@ -297,6 +297,28 @@ (push variable-name (variables construct))))) + +(defgeneric cast-variable-values(construct variable-value-list) + (:documentation "Casts all values contained in the variable value list + to the corresponding type that is also stored in the + variable-value list.") + (:method ((construct SPARQL-Query) (variable-value-list List)) + (map 'list + #'(lambda(item) + (map 'list + #'(lambda(inner-item) + (list :variable-name (getf inner-item :variable-name) + :variable-value + (if (and (getf inner-item :variable-value) + (getf inner-item :literal-datatype)) + (cast-literal (getf inner-item :variable-value) + (getf inner-item :literal-datatype) + :back-as-string-when-unsupported t) + (getf inner-item :variable-value)))) + item)) + variable-value-list))) + + (defgeneric make-variable-values(construct variable-name existing-results) (:documentation "Returns a list of values that are bound to the passed variable. The first occurrence of the given variable @@ -310,29 +332,40 @@ when (and (variable-p (subject triple)) (string= (value (subject triple)) variable-name)) return (progn (setf found-p t) - (subject-result triple)) + (list :result (subject-result triple))) when (and (variable-p (predicate triple)) (string= (value (predicate triple)) variable-name)) return (progn (setf found-p t) - (predicate-result triple)) + (list :result (predicate-result triple))) when (and (variable-p (object triple)) (string= (value (object triple)) variable-name)) return (progn (setf found-p t) - (object-result triple)))) + (list :result (object-result triple) + :literal-datatype (object-datatype triple))))) (new-results nil)) (if (not found-p) existing-results (if existing-results - (dolist (result results new-results) + (dotimes (idx (length (getf results :result)) new-results) (dolist (old-result existing-results) - (push (append old-result (list (list :variable-name variable-name - :variable-value result))) + (push (append old-result + (list + (list :variable-name variable-name + :literal-datatype + (when (getf results :literal-datatype) + (elt (getf results :literal-datatype) idx)) + :variable-value + (elt (getf results :result) idx)))) new-results))) - (map 'list #'(lambda(result) - (list (list :variable-name variable-name - :variable-value result))) - results)))))) + (loop for idx to (1- (length (getf results :result))) + collect (list + (list :variable-name variable-name + :literal-datatype + (when (getf results :literal-datatype) + (elt (getf results :literal-datatype) idx)) + :variable-value + (elt (getf results :result) idx))))))))) (defun to-lisp-code (variable-values filter) @@ -389,16 +422,24 @@ (dolist (var-name filter-variable-names) (setf filter-variable-values (make-variable-values construct var-name filter-variable-values))) + (setf filter-variable-values + (cast-variable-values construct filter-variable-values)) (dolist (filter (filters construct)) (dolist (var-elem filter-variable-values) + + ;(format t "~a~%==>~a~%~%" (to-lisp-code var-elem filter) + ;(eval (read-from-string (to-lisp-code var-elem filter)))) ;TODO: remove + (when (eval (read-from-string (to-lisp-code var-elem filter))) (map 'list #'(lambda(list-elem) (push list-elem true-values)) var-elem)))) + ;(format t "tv: -->~a<--~%" true-values) ;TODO: remove (let ((values-to-remove (return-false-values filter-variable-values (remove-duplicates true-values :test #'variable-list=)))) + ;(format t "vr: -->~a<--~%" values-to-remove) ;TODO: remove (dolist (to-del values-to-remove) (delete-rows-by-value construct (getf to-del :variable-name) (getf to-del :variable-value)))))) @@ -415,8 +456,18 @@ (local-results (cond ((eql what :subject) (subject-result construct)) ((eql what :predicate) (predicate-result construct)) - ((eql what :object) (object-result construct)))) - (is-variable + ((eql what :object) + (if (object-datatype construct) + (loop for idx to (1- (length (object-result construct))) + when (elt (object-datatype construct) idx) + collect (cast-literal + (elt (object-result construct) idx) + (elt (object-datatype construct) idx) + :back-as-string-when-unsupported t) + else + collect (elt (object-result construct) idx)) + (object-result construct))))) + (variable-p (cond ((eql what :subject) (and (variable-p (subject construct)) (value (subject construct)))) @@ -426,7 +477,7 @@ ((eql what :object) (and (variable-p (object construct)) (value (object construct))))))) - (when is-variable + (when variable-p (remove-null (dotimes (idx (length local-results)) (when (literal= variable-value (elt local-results idx)) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Apr 6 07:01:57 2011 @@ -2365,22 +2365,22 @@ "SELECT * WHERE { <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 - FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 - FILTER (?obj1 = 'von Goethe' || 82 = ?obj1) - FILTER (?obj1 = 'von Goethe') || (82 = ?obj1) - FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))" - " + #FILTER ?obj1 = 'von Goethe' || ?obj1 = '82'^^" *xml-integer* " + #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1) + #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1) + #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))" + " }")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) - (map 'list #'(lambda(triple) - (format t "~a - ~a - ~a[~a]~%" - (tm-sparql::subject-result triple) - (tm-sparql::predicate-result triple) - (tm-sparql::object-result triple) - (tm-sparql::object-datatype triple))) - (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))) + ;(map 'list #'(lambda(triple) + ;(format t "~a - ~a - ~a[~a]~%" + ;(tm-sparql::subject-result triple) + ;(tm-sparql::predicate-result triple) + ;(tm-sparql::object-result triple) + ;(tm-sparql::object-datatype triple))) + ;(tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))

1 0

[isidorus-cvs] r417 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 06 Apr '11

06 Apr '11

Author: lgiessmann Date: Wed Apr 6 05:26:02 2011 New Revision: 417 Log: TM-SPARQL: adopted all unit-tests to the latest changes; fixed some bug that handles unsupported datatypes Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/base-tools/base-tools.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Wed Apr 6 05:26:02 2011 @@ -589,7 +589,7 @@ (list :subject subj-uri :predicate pred-uri :object (charvalue char) - :literal-datatype literal-datatype)))) + :literal-datatype literal-datatype)))) (remove-if #'(lambda(char) (typep char 'VariantC)) (return-characteristics literal-value literal-datatype))))) @@ -909,8 +909,10 @@ (string/= literal-datatype *xml-boolean*)) construct (handler-case - (let ((occ-value (cast-literal (charvalue construct) - (datatype construct)))) + (let ((occ-value + (cast-literal (charvalue construct) + (datatype construct) + :back-as-string-when-unsupported t))) (when (literal= occ-value literal-value) construct)) (condition () nil))))) @@ -1279,10 +1281,12 @@ values))) -(defun cast-literal (literal-value literal-type) +(defun cast-literal (literal-value literal-type + &key (back-as-string-when-unsupported nil)) "A helper function that casts the passed string value of the literal corresponding to the passed literal-type." - (declare (String literal-value literal-type)) + (declare (String literal-value literal-type) + (Boolean back-as-string-when-unsupported)) (cond ((string= literal-type *xml-string*) literal-value) ((string= literal-type *xml-boolean*) @@ -1294,7 +1298,9 @@ ((string= literal-type *xml-decimal*) (cast-literal-to-decimal literal-value)) (t ; return the value as a string - (concat "\"\"\"" literal-value "\"\"\"^^" literal-type)))) + (if back-as-string-when-unsupported + literal-value + (concat "\"\"\"" literal-value "\"\"\"^^" literal-type))))) (defun cast-literal-to-decimal (literal-value) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Wed Apr 6 05:26:02 2011 @@ -230,7 +230,8 @@ (l-lang (getf result-2 :lang)) (next-query (getf result-2 :next-query))) (list :next-query next-query :lang l-lang :type l-type - :value (cast-literal l-value l-type))))) + :value (cast-literal l-value l-type + :back-as-string-when-unsupported t))))) (defgeneric separate-literal-lang-or-type (construct query-string) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Wed Apr 6 05:26:02 2011 @@ -195,12 +195,15 @@ (let ((search-idx (search-first (list string-to-replace) main-string))) (if (not search-idx) main-string - (let ((modified-string - (concat (subseq main-string 0 search-idx) - new-string - (subseq main-string - (+ search-idx (length string-to-replace)))))) - (string-replace modified-string string-to-replace new-string)))))) + (let* ((leading-part (subseq main-string 0 search-idx)) + (trailing-part + (subseq main-string + (+ search-idx (length string-to-replace)))) + (modified-string + (concat leading-part new-string trailing-part))) + (if (search-first (list string-to-replace) trailing-part) + (string-replace modified-string string-to-replace new-string) + modified-string)))))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Apr 6 05:26:02 2011 @@ -41,20 +41,20 @@ :test-set-functions :test-module-1 :test-module-2 - :test-all-1 - :test-all-2 - :test-all-3 - :test-all-4 - :test-all-5 - :test-all-6 - :test-all-7 - :test-all-8 - :test-all-9 - :test-all-10 - :test-all-11 - :test-all-12 - :test-all-13 - :test-all-14)) + :test-module-3 + :test-module-4 + :test-module-5 + :test-module-6 + :test-module-7 + :test-module-8 + :test-module-9 + :test-module-10 + :test-module-11 + :test-module-12 + :test-module-13 + :test-module-14 + :test-module-15 + :test-module-16)) (in-package :sparql-test) @@ -1603,7 +1603,7 @@ (is-false (set-exclusive-or (getf (second result-2) :result) (list "Johann Wolfgang" "von Goethe" - "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") + (concat "\"\"\"http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe\"\"\"^^" *xml-uri*)) :test #'string=))) (progn (is (= (length (getf (second result-2) :result)) 0)) @@ -1612,7 +1612,7 @@ (is-false (set-exclusive-or (getf (first result-2) :result) (list "Johann Wolfgang" "von Goethe" - "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") + (concat "\"\"\"http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe\"\"\"^^" *xml-uri*)) :test #'string=)))))))) @@ -1642,7 +1642,7 @@ :test #'string=)))))) -(test test-all-1 +(test test-module-3 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1698,7 +1698,7 @@ (is-true (d:get-item-by-psi *rdf-type* :revision 0)))) -(test test-all-2 +(test test-module-4 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1724,7 +1724,7 @@ r-1)))) -(test test-all-3 +(test test-module-5 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1752,7 +1752,7 @@ r-1)))) -(test test-all-4 +(test test-module-6 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1802,7 +1802,7 @@ r-1)))) -(test test-all-5 +(test test-module-7 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1831,7 +1831,7 @@ r-1)))) -(test test-all-6 +(test test-module-8 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1874,7 +1874,7 @@ r-1)))) -(test test-all-7 +(test test-module-9 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1898,7 +1898,7 @@ r-1)))) -(test test-all-8 +(test test-module-10 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1921,7 +1921,8 @@ "Johann Wolfgang von Goethe"))) ((string= (getf item :variable) "obj2") (is (string= (first (getf item :result)) - "28.08.1749"))) + (concat "\"\"\"28.08.1749\"\"\"^^" + *xml-date*)))) ((string= (getf item :variable) "obj3") (is (string= (first (getf item :result)) "Goethe"))) @@ -1942,7 +1943,7 @@ r-1)))) -(test test-all-9 +(test test-module-11 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -1961,7 +1962,7 @@ (is-false r-1)))) -(test test-all-10 +(test test-module-12 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -2074,7 +2075,7 @@ r-1)))) -(test test-all-11 +(test test-module-13 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -2127,24 +2128,27 @@ ((string= (getf item :variable) "obj1") (is (= (length (getf item :result)) 17)) (is-true (find "Johann Wolfgang" (getf item :result) - :test #'string=)) + :test #'tm-sparql::literal=)) (is-true (find "von Goethe" (getf item :result) - :test #'string=)) - (is-true (find "true" (getf item :result) - :test #'string=)) - (is-true (find "false" (getf item :result) - :test #'string=)) - (is-true (find "28.08.1749" (getf item :result) - :test #'string=)) - (is-true (find "22.03.1832" (getf item :result) - :test #'string=)) - (is-true (find "82" (getf item :result) - :test #'string=)) + :test #'tm-sparql::literal=)) + (is-true (find t (getf item :result) + :test #'tm-sparql::literal=)) + (is-true (position nil (getf item :result) + :test #'tm-sparql::literal=)) + (is-true (find (concat "'28.08.1749'^^" *xml-date*) + (getf item :result) + :test #'tm-sparql::literal=)) + (is-true (find (concat "'22.03.1832'^^" *xml-date*) + (getf item :result) + :test #'tm-sparql::literal=)) + (is-true (find 82 (getf item :result) + :test #'tm-sparql::literal=)) (is-true (find "<http://some.where/tmsparql/author>" - (getf item :result) :test #'string=)) + (getf item :result) + :test #'tm-sparql::literal=)) (is-true (find "<http://some.where/psis/poem/zauberlehrling>" - (getf item :result) :test #'string=))) + (getf item :result) :test #'tm-sparql::literal=))) ((string= (getf item :variable) "obj2") (is (= (length (getf item :result)) 3)) (is-false @@ -2182,9 +2186,9 @@ (is-false (set-exclusive-or (getf item :result) - (list "28.08.1749" + (list (concat "'28.08.1749'^^" *xml-date*) "<http://some.where/ii/goethe-occ-reifier>") - :test #'string=))) + :test #'tm-sparql::literal=))) ((string= (getf item :variable) "obj6") (is (= (length (getf item :result)) 2)) (is-false @@ -2198,7 +2202,7 @@ r-1)))) -(test test-all-12 +(test test-module-14 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -2312,7 +2316,7 @@ -(test test-all-13 +(test test-module-15 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) @@ -2353,14 +2357,14 @@ r-1)))) -(test test-all-14 +(test test-module-16 "Tests the entire module with the file sparql_test.xtm" (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) (tm-sparql:init-tm-sparql) (let* ((q-1 (concat "SELECT * WHERE { <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. - FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 + FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 FILTER (?obj1 = 'von Goethe' || 82 = ?obj1) FILTER (?obj1 = 'von Goethe') || (82 = ?obj1) @@ -2393,8 +2397,6 @@ ;TODO: cast literal-values when called in filters ;TODO: test complex filters -;TODO: check if object results are in the actual object-represenrtation and not as string -;TODO: rename test-all-? test-module-? (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

[isidorus-cvs] r416 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 05 Apr '11

05 Apr '11

Author: lgiessmann Date: Tue Apr 5 17:36:42 2011 New Revision: 416 Log: TM-SPARQL: fixed a bug in recursive-intersection Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Tue Apr 5 17:36:42 2011 @@ -1176,7 +1176,9 @@ (if (not more-lists) (list :result current-result :literal-datatype current-datatypes) - (recursive-intersection current-result (first more-lists) + (recursive-intersection (list :result current-result + :literal-datatype current-datatypes) + (first more-lists) (rest more-lists))))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Apr 5 17:36:42 2011 @@ -2391,7 +2391,7 @@ (format t "~a~%" r-1)))) - +;TODO: cast literal-values when called in filters ;TODO: test complex filters ;TODO: check if object results are in the actual object-represenrtation and not as string ;TODO: rename test-all-? test-module-?

1 0

[isidorus-cvs] r415 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 05 Apr '11

05 Apr '11

Author: lgiessmann Date: Tue Apr 5 17:12:56 2011 New Revision: 415 Log: TM-SPARQL: all result values are returned in the correct datatype representation, if there are unsupported datatypes requested the return value is of the form """value"""^^datatype Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Tue Apr 5 17:12:56 2011 @@ -106,7 +106,7 @@ :initform nil :documentation "Contains the datatype of the literal, e.g. xml:string")) - (:documentation "Represents one element of an RDF-triple.")) + (:documentation "Represents one element of an RDF-triple.")) (defclass SPARQL-Triple() @@ -147,9 +147,14 @@ :documentation "Represents the subject of an RDF-triple.") (object-result :initarg :object-result :accessor object-result - :type T + :type List :initform nil - :documentation "Contains the result of the object triple elem.")) + :documentation "Contains the result of the object triple elem.") + (object-datatype :initarg :object-datatype + :accessor object-datatype + :type List + :initform nil + :documentation "Conations the corresponding value's datatype.")) (:documentation "Represents an entire RDF-triple.")) @@ -377,9 +382,6 @@ (:documentation "Processes all filters by calling invoke-filter.") (:method ((construct SPARQL-Query)) (dolist (filter (filters construct)) - - (format t ">>>~a<<<~%" filter) ;TODO: remove - (let* ((filter-variable-names (get-variables-from-filter-string filter)) (filter-variable-values nil) @@ -453,14 +455,18 @@ (push (list :subject (elt (subject-result triple) idx) :predicate (elt (predicate-result triple) idx) - :object (elt (object-result triple) idx)) + :object (elt (object-result triple) idx) + :object-datatype (elt (object-datatype triple) idx)) new-values))) (setf (subject-result triple) (map 'list #'(lambda(elem) (getf elem :subject)) new-values)) (setf (predicate-result triple) (map 'list #'(lambda(elem) (getf elem :predicate)) new-values)) (setf (object-result triple) - (map 'list #'(lambda(elem) (getf elem :object)) new-values)))))) + (map 'list #'(lambda(elem) (getf elem :object)) new-values)) + (setf (object-datatype triple) + (map 'list #'(lambda(elem) (getf elem :object-datatype)) + new-values)))))) construct)) @@ -477,13 +483,11 @@ (filter-by-given-object construct :revision revision)) (filter-by-special-uris construct :revision revision)))) (map 'list #'(lambda(result) - ;(format t "-->~a<--~%" result) ;TODO: remove (push (getf result :subject) (subject-result construct)) (push (getf result :predicate) (predicate-result construct)) - (push (getf result :object) (object-result construct))) - ;;literal-datatype is not used and is not returned, since - ;;the values are returned as object of their specific type, e.g. - ;;integer, boolean, string, ... + (push (getf result :object) (object-result construct)) + (push (getf result :literal-datatype) + (object-datatype construct))) results))))) @@ -1064,11 +1068,36 @@ (all-variables construct) (variables construct)))) (cleaned-results (make-result-lists construct))) - (map 'list #'(lambda(response-variable) - (list :variable response-variable - :result (variable-intersection response-variable + (let ((result + (map 'list #'(lambda(response-variable) + (let ((result + (variable-intersection response-variable cleaned-results))) - response-variables)))) + (list :variable response-variable + :result (getf result :result) + :literal-datatype + (getf result :literal-datatype)))) + response-variables))) + (cast-result-values result))))) + + +(defun cast-result-values (result-values) + "Casts all literal values that are represented as a string to + the actual datatype." + (declare (List result-values)) + (loop for set-idx to (1- (length result-values)) + collect (let ((value-set (getf (elt result-values set-idx) :result)) + (type-set (getf (elt result-values set-idx) :literal-datatype)) + (var-name (getf (elt result-values set-idx) :variable))) + (list :variable var-name + :result + (loop for value-idx to (1- (length value-set)) + when (elt type-set value-idx) + collect (cast-literal (elt value-set value-idx) + (elt type-set value-idx)) + else + collect (elt value-set value-idx)))))) + (defgeneric make-result-lists (construct) @@ -1087,6 +1116,7 @@ :result (predicate-result triple))) (when (variable-p (object triple)) (list :variable (value (object triple)) + :literal-datatype (object-datatype triple) :result (object-result triple))))))))) @@ -1130,14 +1160,22 @@ (defun recursive-intersection (list-1 list-2 more-lists) "Returns an intersection of al the passed lists." (declare (List list-1 list-2)) - (let ((current-result - (intersection list-1 list-2 - :test #'(lambda(val-1 val-2) - (if (and (stringp val-1) (stringp val-2)) - (string= val-1 val-2) - (eql val-1 val-2)))))) + (let* ((current-result + (intersection (getf list-1 :result) (getf list-2 :result) + :test #'(lambda(val-1 val-2) + (if (and (stringp val-1) (stringp val-2)) + (string= val-1 val-2) + (eql val-1 val-2))))) + (current-datatypes + (map 'list #'(lambda(result-entry) + (let ((pos (position result-entry (getf list-1 :result) + :test #'string=))) + (when (getf list-1 :literal-datatype) + (elt (getf list-1 :literal-datatype) pos)))) + current-result))) (if (not more-lists) - current-result + (list :result current-result + :literal-datatype current-datatypes) (recursive-intersection current-result (first more-lists) (rest more-lists))))) @@ -1157,10 +1195,13 @@ (:method ((construct SPARQL-Triple) (result-lists List)) (let* ((triple-variables (variables construct)) (intersections - (map 'list #'(lambda(var) - (list :variable var - :result (variable-intersection - var result-lists))) + (map 'list + #'(lambda(var) + (let ((result (variable-intersection + var result-lists))) + (list :variable var + :result (getf result :result) + :literal-datatype (getf result :literal-datatype)))) triple-variables))) (map 'list #'(lambda(entry) (delete-rows construct (getf entry :variable) @@ -1197,11 +1238,14 @@ (find (elt var-elem idx) dont-touch-values))) collect idx)) (new-result-list - (map 'list - #'(lambda(row-idx) - (list :subject (elt (subject-result construct) row-idx) - :predicate (elt (predicate-result construct) row-idx) - :object (elt (object-result construct) row-idx))) + (map + 'list + #'(lambda(row-idx) + (list + :subject (elt (subject-result construct) row-idx) + :predicate (elt (predicate-result construct) row-idx) + :object (elt (object-result construct) row-idx) + :object-datatype (elt (object-datatype construct) row-idx))) rows-to-hold))) (setf (subject-result construct) (map 'list #'(lambda(entry) @@ -1211,7 +1255,10 @@ (getf entry :predicate)) new-result-list)) (setf (object-result construct) (map 'list #'(lambda(entry) - (getf entry :object)) new-result-list))))))) + (getf entry :object)) new-result-list)) + (setf (object-datatype construct) + (map 'list #'(lambda(entry) + (getf entry :object-datatype)) new-result-list))))))) (defgeneric results-for-variable (variable-name result-lists) @@ -1224,7 +1271,8 @@ result-lists)) (values (map 'list #'(lambda(entry) - (getf entry :result)) + (list :result (getf entry :result) + :literal-datatype (getf entry :literal-datatype))) cleaned-result-lists))) values))) @@ -1244,7 +1292,7 @@ ((string= literal-type *xml-decimal*) (cast-literal-to-decimal literal-value)) (t ; return the value as a string - literal-value))) + (concat "\"\"\"" literal-value "\"\"\"^^" literal-type)))) (defun cast-literal-to-decimal (literal-value) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Apr 5 17:12:56 2011 @@ -40,7 +40,21 @@ :test-set-compare-operators :test-set-functions :test-module-1 - :test-module-2)) + :test-module-2 + :test-all-1 + :test-all-2 + :test-all-3 + :test-all-4 + :test-all-5 + :test-all-6 + :test-all-7 + :test-all-8 + :test-all-9 + :test-all-10 + :test-all-11 + :test-all-12 + :test-all-13 + :test-all-14)) (in-package :sparql-test) @@ -219,7 +233,7 @@ (let ((res (tm-sparql::parse-literal-elem dummy-object query-6))) (is (string= (getf res :next-query) (concat "." (string #\newline)))) - (is (eql (tm-sparql::value (getf res :value)) 123.4)) + (is (eql (tm-sparql::value (getf res :value)) 123.4d0)) (is-false (tm-sparql::literal-lang (getf res :value))) (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-double*)) @@ -2049,12 +2063,12 @@ (getf item :result) (list "Johann Wolfgang" "von Goethe" "Johann Wolfgang von Goethe" "Der Zauberlehrling" - "28.08.1749" "22.03.1832" "82" "true" "false" + "28.08.1749" "22.03.1832" 82 t nil "Hat der alte Hexenmeister sich doch einmal wegbegeben! ... ") - :test #'string=)) + :test #'tm-sparql::literal=)) (t (is-true (format t "bad variable-name found"))))) r-1)))) @@ -2346,31 +2360,22 @@ (let* ((q-1 (concat "SELECT * WHERE { <http://some.where/tmsparql/author/goethe> ?pred1 ?obj1. - FILTER ?obj1 = 'von Goethe' || ?obj1 = '82' - #FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 - #FILTER (?obj1 = 'von Goethe' || 82 = ?obj1) - #FILTER (?obj1 = 'von Goethe') || (82 = ?obj1) - #FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))" + FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 + FILTER ?obj1 = 'von Goethe' || ?obj1 = 82 + FILTER (?obj1 = 'von Goethe' || 82 = ?obj1) + FILTER (?obj1 = 'von Goethe') || (82 = ?obj1) + FILTER ((?obj1 = 'von Goethe') || (82 = ?obj1))" " }")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) - - ;;TODO: use all stored literal datatype information if existent and - ;; cast the values to the actual objects - ;; or - ;; write all string values to the results in a quoted form, - ;; it is also needed to escapte quotes in the actual string value - ;; the filter is called with read-from-string, so a "12" will evaluate - ;; to 12 and "\"abc\"" to "abc - (map 'list #'(lambda(triple) - (format t "~a - ~a - ~a(~a)~%" + (format t "~a - ~a - ~a[~a]~%" (tm-sparql::subject-result triple) (tm-sparql::predicate-result triple) (tm-sparql::object-result triple) - (tm-sparql::literal-datatype triple))) + (tm-sparql::object-datatype triple))) (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1))) @@ -2388,6 +2393,8 @@ ;TODO: test complex filters +;TODO: check if object results are in the actual object-represenrtation and not as string +;TODO: rename test-all-? test-module-? (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs