April 2011 - isidorus-cvs@common-lisp.net

[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

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

05 Apr '11

Author: lgiessmann Date: Tue Apr 5 07:23:28 2011 New Revision: 414 Log: changed the behavior of casting string-values to xml-boolean, xml-integer, xml-double and xml-decimal 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 07:23:28 2011 @@ -477,6 +477,7 @@ (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))) @@ -1235,35 +1236,88 @@ (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)) + (cast-literal-to-boolean literal-value)) ((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)) + (cast-literal-to-integer literal-value)) + ((string= literal-type *xml-double*) + (cast-literal-to-double literal-value)) + ((string= literal-type *xml-decimal*) + (cast-literal-to-decimal literal-value)) (t ; return the value as a string literal-value))) +(defun cast-literal-to-decimal (literal-value) + "A helper function that casts the passed string value of the literal + value to an decimal value." + (let ((bad-string + (loop for idx to (1- (length literal-value)) + when (and (not (digit-char-p (elt literal-value idx))) + (not (eql (elt literal-value idx) #\.))) + return t))) + (when bad-string + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value *xml-decimal*))))) + ;decimals are handled as single floats + (if (find #\. literal-value) + (read-from-string literal-value) + (read-from-string (concat literal-value ".0")))) + + +(defun cast-literal-to-double (literal-value) + "A helper function that casts the passed string value of the literal + value to an decimal value." + (let ((modified-str "")) + (loop for idx to (1- (length literal-value)) + when (eql (char-downcase (elt literal-value idx)) #\e) + do (push-string "d" modified-str) + else + do (push-string (string (elt literal-value idx)) modified-str)) + (let ((value + (cond ((or (string= "+INF" modified-str) + (string= "INF" modified-str)) + sb-ext:double-float-positive-infinity) + ((string= "-INF" modified-str) + sb-ext:double-float-negative-infinity) + ((find #\d (string-downcase modified-str)) + (read-from-string modified-str)) + (t + (read-from-string (concat modified-str "d0")))))) + (if (typep value 'double-float) + value + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value *xml-double*))))))) + + +(defun cast-literal-to-integer (literal-value) + "A helper function that casts the passed string value of the literal + value to an integer value." + (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 *xml-integer*)))))) + + +(defun cast-literal-to-boolean (literal-value) + "A helper function that casts the passed string value of the literal + value to t or nil." + (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 *xml-boolean*)))) + (if (string= literal-value "false") + nil + t)) + + (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) 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 07:23:28 2011 @@ -2366,10 +2366,11 @@ ;; to 12 and "\"abc\"" to "abc (map 'list #'(lambda(triple) - (format t "~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::object-result triple) + (tm-sparql::literal-datatype triple))) (tm-sparql::select-group (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))

1 0

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

05 Apr '11

Author: lgiessmann Date: Tue Apr 5 05:31:40 2011 New Revision: 413 Log: changed the behavior of the handling of paranthesis and quotations in filters and the behavior of hanlding SPARQL comments 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 Tue Apr 5 05:31:40 2011 @@ -377,6 +377,9 @@ (: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) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Tue Apr 5 05:31:40 2011 @@ -38,7 +38,10 @@ (if (string-starts-with trimmed-str "#") (let ((next-query (string-after trimmed-str (string #\newline)))) (if next-query - next-query + (let ((cleaned-next-query (cut-comment next-query))) + (if (string= next-query cleaned-next-query) + next-query + (cut-comment next-query))) "")) trimmed-str))) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Tue Apr 5 05:31:40 2011 @@ -437,25 +437,35 @@ (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))))))))) + (let* ((current-str (subseq filter-string idx)) + (delimiter (cond ((string-starts-with current-str "'''") + "'''") + ((string-starts-with current-str "'") + "'") + ((string-starts-with current-str "\"\"\"") + "\"\"\"") + ((string-starts-with current-str "\"") + "\"")))) + (when delimiter + (let* ((end-pos + (let ((result + (search-first (list delimiter) + (subseq current-str (length delimiter))))) + (when result + (+ (length delimiter) result)))) + (quoted-str (when end-pos + (subseq current-str (length delimiter) end-pos))) + (start-pos idx)) + (incf idx (+ (* 2 (length delimiter)) (length quoted-str))) + (if (and (>= pos start-pos) + (<= pos (+ start-pos end-pos))) + (progn + (setf result t) + (setf idx (length filter-string))) + (incf idx (+ (* 2 (length delimiter)) (length quoted-str)))))))))) -(defun search-first-unclosed-paranthesis (str &key ignore-literals) +(defun search-first-unclosed-paranthesis (str &key (ignore-literals t)) "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 @@ -467,12 +477,14 @@ (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))) + (when (or (not ignore-literals) + (and 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))) + (when (or (not ignore-literals) + (and ignore-literals + (not (in-literal-string-p str idx)))) (incf open-brackets) (when (> open-brackets 0) (setf result-idx idx) @@ -481,7 +493,7 @@ result-idx)) -(defun search-first-unopened-paranthesis (str &key ignore-literals) +(defun search-first-unopened-paranthesis (str &key (ignore-literals t)) "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." @@ -492,13 +504,15 @@ (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))) + (when (or (not ignore-literals) + (and 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))) + (when (or (not ignore-literals) + (and ignore-literals + (not (in-literal-string-p str idx)))) (incf closed-brackets) (when (> closed-brackets 0) (setf result-idx idx) 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 05:31:40 2011 @@ -2339,6 +2339,52 @@ r-1)))) +(test test-all-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) + (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))" + " +}")) + (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~%" + (tm-sparql::subject-result triple) + (tm-sparql::predicate-result triple) + (tm-sparql::object-result 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 + ((string= (getf item :variable) "pred1") + nil) + ((string= (getf item :variable) "obj1") + nil))) + r-1) + (format t "~a~%" r-1)))) + + ;TODO: test complex filters

1 0

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

04 Apr '11

Author: lgiessmann Date: Mon Apr 4 04:50:25 2011 New Revision: 412 Log: TM-SPARQL: fixed a bug in the processing of final results when creating result-intersections and finished a unit-tests for such a scenario 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 Mon Apr 4 04:50:25 2011 @@ -1080,7 +1080,7 @@ :result (subject-result triple))) (when (variable-p (predicate triple)) (list :variable (value (predicate triple)) - :result (predicate-result triple))) + :result (predicate-result triple))) (when (variable-p (object triple)) (list :variable (value (object triple)) :result (object-result triple))))))))) @@ -1116,7 +1116,7 @@ (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) + (list-2 (if (>= (length all-values) 2) (second all-values) list-1)) (more-lists (rest (rest all-values)))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Mon Apr 4 04:50:25 2011 @@ -2079,6 +2079,7 @@ (map 'list #'(lambda(item) (cond ((string= (getf item :variable) "pred1") ;one name without a type so it is not listed + ;as regular triple but as tms:topicProperty (is (= (length (getf item :result)) 17))) ((string= (getf item :variable) "pred2") (is (= (length (getf item :result)) 3)) @@ -2297,17 +2298,49 @@ +(test test-all-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) + (let* ((q-1 (concat + "PREFIX tms:<" *tms* "> + SELECT * WHERE { + ?assoc tms:reifier <http://some.where/ii/association-reifier>. + ?assoc tms:role ?roles. + ?roles tms:reifier <http://some.where/ii/role-reifier>" + "}")) + (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) "assoc") + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + "<http://some.where/ii/association>"))) + ((string= (getf item :variable) "roles") + (is (= (length (getf item :result)) 1)) + (is + (string= + (first (getf item :result)) + (concat + "_:r" + (write-to-string + (elephant::oid + (loop for role in + (roles + (get-item-by-item-identifier + "http://some.where/ii/association" + :revision 0) :revision 0) + when (string= + (uri (first (psis (player role :revision 0) + :revision 0))) + "http://some.where/tmsparql/author/goethe") + return role))))))))) + r-1)))) -;TODO: test complex filters, -; test complex relations between variables -;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/> -; SELECT * WHERE { -; ?assoc tms:reifier <http://some.where/ii/association-reifier>. -; ?assoc tms:role ?roles} -; => ?assoc = http://some.where/ii/association -; => ?roles = (http://some.where/ii/role-2, _:r????) +;TODO: test complex filters (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

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

03 Apr '11

Author: lgiessmann Date: Sun Apr 3 17:12:18 2011 New Revision: 411 Log: TM-SPARQL: fixed a bug in the processing of the property tms:topicProperty; finished the unit-tests for triples of the form ?var1 ?var2 <obj> Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_special_uris.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 Sun Apr 3 17:12:18 2011 @@ -495,7 +495,8 @@ (filter-by-characteristic-value (value (object construct)) (literal-datatype (object construct)) :revision revision)) - ((iri-p (object construct)) + ((and (iri-p (object construct)) + (typep (value (object construct)) 'TopicC)) (filter-by-otherplayer (value (object construct)) :revision revision)))))) @@ -1073,8 +1074,6 @@ (remove-null (loop for triple in (select-group construct) append (remove-null - ;;TODO: replace remove-null by a function that check if any of the - ;; list items is nil, if so the entire list should be nil (list (when (variable-p (subject triple)) (list :variable (value (subject triple)) 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 Sun Apr 3 17:12:18 2011 @@ -93,9 +93,16 @@ (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))) + (res-6 + (progn + (setf (value pred) (get-item-by-psi *tms-topicProperty* + :revision revision)) + (let ((val (filter-for-topicProperties construct :revision revision))) + (setf (value pred) old-pred-value) val)))) (setf (elem-type (predicate construct)) 'VARIABLE) - (append res-1 res-2 res-3 res-4 res-5)))) + (append res-1 res-2 res-3 res-4 res-5 res-6)))) (defgeneric filter-for-player (construct &key revision) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Apr 3 17:12:18 2011 @@ -2079,7 +2079,7 @@ (map 'list #'(lambda(item) (cond ((string= (getf item :variable) "pred1") ;one name without a type so it is not listed - (is (= (length (getf item :result)) 9))) + (is (= (length (getf item :result)) 17))) ((string= (getf item :variable) "pred2") (is (= (length (getf item :result)) 3)) (is-false (set-exclusive-or @@ -2110,15 +2110,26 @@ (concat "<" *tms-scope* ">")) :test #'string=))) ((string= (getf item :variable) "obj1") - (is (= (length (getf item :result)) 9)) - (is-false (set-exclusive-or - (getf item :result) - (list "Johann Wolfgang" "von Goethe" - "28.08.1749" "22.03.1832" "82" - "true" "false" - "<http://some.where/tmsparql/author>" - "<http://some.where/psis/poem/zauberlehrling>") - :test #'string=))) + (is (= (length (getf item :result)) 17)) + (is-true (find "Johann Wolfgang" (getf item :result) + :test #'string=)) + (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=)) + (is-true (find "<http://some.where/tmsparql/author>" + (getf item :result) :test #'string=)) + (is-true + (find "<http://some.where/psis/poem/zauberlehrling>" + (getf item :result) :test #'string=))) ((string= (getf item :variable) "obj2") (is (= (length (getf item :result)) 3)) (is-false @@ -2172,10 +2183,124 @@ r-1)))) +(test test-all-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) + (let* ((q-1 (concat + "PREFIX tms:<http://www.networkedplanet.com/tmsparql/> + SELECT * WHERE { + ?subj1 ?pred1 <http://some.where/tmsparql/author/goethe>. + ?subj2 ?pred2 <http://some.where/ii/goethe-variant>. + ?subj3 ?pred3 <http://some.where/ii/goethe-untyped-name>. + ?subj4 ?pred4 <http://some.where/ii/goethe-occ>. + ?subj5 ?pred5 <http://some.where/ii/association>. + ?subj6 ?pred6 <http://some.where/ii/role-2>. + ?subj7 ?pred7 <http://some.where/tmsparql/display-name>. + ?subj8 ?pred8 <http://some.where/ii/role-reifier>" + "}")) + (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) + (is-true (= (length r-1) 16)) + (map 'list #'(lambda(item) + (cond ((string= (getf item :variable) "pred1") + (is (= (length (getf item :result)) 4)) + (is-false + (set-exclusive-or + (list (concat "<" *instance-psi* ">") + "<http://some.where/tmsparql/writer>" + (concat "<" *tms-player* ">")) + (getf item :result) :test #'string=))) + ((string= (getf item :variable) "obj1") + (is (= (length (getf item :result)) 4)) + (is-false + (set-exclusive-or + (list "<http://some.where/tmsparql/author>" + "<http://some.where/psis/poem/zauberlehrling>" + (concat + "_:r" + (write-to-string + (elephant::oid + (first + (player-in-roles + (get-item-by-psi + "http://some.where/tmsparql/author/goethe" + :revision 0) :revision 0))))) + (concat + "_:r" + (write-to-string + (elephant::oid + (second + (player-in-roles + (get-item-by-psi + "http://some.where/tmsparql/author/goethe" + :revision 0) :revision 0)))))) + (getf item :result) :test #'string=))) + ((or (string= (getf item :variable) "pred2") + (string= (getf item :variable) "pred5")) + (is-false (getf item :result))) + ((or (string= (getf item :variable) "subj2") + (string= (getf item :variable) "obj5")) + (is-false (getf item :result))) + ((or (string= (getf item :variable) "pred3") + (string= (getf item :variable) "pred4")) + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + (concat "<" *tms-topicProperty* ">")))) + ((or (string= (getf item :variable) "subj3") + (string= (getf item :variable) "obj4")) + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + "<http://some.where/tmsparql/author/goethe>"))) + ((string= (getf item :variable) "pred6") + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + (concat "<" *tms-role* ">")))) + ((string= (getf item :variable) "subj6") + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + "<http://some.where/ii/association>"))) + ((string= (getf item :variable) "pred7") + (is (= (length (getf item :result)) 3)) + (is-false (set-exclusive-or + (list (concat "<" *tms-player* ">") + (concat "<" *tms-scope* ">") + (concat "<" *instance-psi* ">")) + (getf item :result) :test #'string=))) + ((string= (getf item :variable) "subj7") + (is (= (length (getf item :result)) 3)) + (is (find "<http://psi.topicmaps.org/tmcl/scope-type>" + (getf item :result) :test #'string=)) + (is (find "<http://some.where/ii/goethe-variant>" + (getf item :result) :test #'string=))) + ((string= (getf item :variable) "pred8") + (is (= (length (getf item :result)) 3)) + (is-false (set-exclusive-or + (list (concat "<" *tms-player* ">") + (concat "<" *tms-reifier* ">") + (concat "<" *instance-psi* ">")) + (getf item :result) :test #'string=))) + ((string= (getf item :variable) "subj8") + (is (= (length (getf item :result)) 3)) + (set-exclusive-or + (list "http://some.where/tmsparql/reifier-type" + (concat + "_:r" + (write-to-string + (elephant::oid + (first + (player-in-roles + (get-item-by-item-identifier + "http://some.where/ii/role-reifier" + :revision 0) :revision 0)))))) + (getf item :result) :test #'string=)))) + r-1)))) + + + + -;TODO: complex filter, -; complex relations between variables -; ?subj ?pred <obj> +;TODO: test complex filters, +; test complex relations between variables ;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/> ; SELECT * WHERE { ; ?assoc tms:reifier <http://some.where/ii/association-reifier>.

1 0

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

03 Apr '11

Author: lgiessmann Date: Sun Apr 3 15:56:15 2011 New Revision: 410 Log: TM-SPARQL: fixed a bug in the processing of final results when making intersections of all triples containing the same variable; finished the unit-tests for triples of the form <subj> ?var1 ?var2 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 Sun Apr 3 15:56:15 2011 @@ -576,10 +576,11 @@ (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))) + (when (and subj-uri pred-uri) + (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))))) @@ -602,13 +603,14 @@ 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))) + (when orole + (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))))) @@ -664,15 +666,16 @@ (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))))) + (when (and orole assoc) + (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)))))) @@ -711,14 +714,16 @@ (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*)) + (when (and (parent name :revision revision) + (instance-of name :revision revision)) + (list :subject + (sparql-node (parent name :revision revision) + :revision revision) + :predicate + (sparql-node (instance-of name :revision revision) + :revision revision) + :object (charvalue name) + :literal-datatype *xml-string*))) names-by-literal)))))) @@ -748,14 +753,16 @@ (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))) + (when (and (parent occ :revision revision) + (instance-of occ :revision revision)) + (list :subject + (sparql-node (parent occ :revision revision) + :revision revision) + :predicate + (sparql-node (instance-of occ :revision revision) + :revision revision) + :object (charvalue occ) + :literal-datatype (datatype occ)))) all-occs)))))) @@ -771,9 +778,9 @@ (cond ((variable-p (object construct)) (when (typep subj 'TopicC) (append (filter-characteristics - subj pred nil nil :revision revision) - (filter-associations - subj pred nil :revision revision)))) + subj pred nil nil :revision revision) + (filter-associations + subj pred nil :revision revision)))) ((literal-p (object construct)) (when (typep subj 'TopicC) (filter-characteristics @@ -937,13 +944,13 @@ (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))) + (when (instance-of occ :revision revision) + (list :subject subj-uri + :predicate (sparql-node + (instance-of occ :revision revision) + :revision revision) + :object (charvalue occ) + :literal-datatype (datatype occ)))) all-occs))))) @@ -968,15 +975,15 @@ (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))))) + (map 'list #'(lambda(name) + (when (instance-of name :revision revision) + (list :subject subj-uri + :predicate (sparql-node + (instance-of name :revision revision) + :revision revision) + :object (charvalue name) + :literal-datatype *xml-string*))) + all-names)))) (defgeneric filter-characteristics (construct type-top literal-value @@ -1037,9 +1044,10 @@ (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)))) + (when (and subj-uri pred-uri obj-uri) + (list :subject subj-uri + :predicate pred-uri + :object obj-uri))))) assocs))))) @@ -1065,6 +1073,8 @@ (remove-null (loop for triple in (select-group construct) append (remove-null + ;;TODO: replace remove-null by a function that check if any of the + ;; list items is nil, if so the entire list should be nil (list (when (variable-p (subject triple)) (list :variable (value (subject triple)) @@ -1102,7 +1112,7 @@ (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.") + an intersection of all partial 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) @@ -1135,7 +1145,7 @@ (:method ((construct SPARQL-Query) (result-lists List)) (map 'list #'(lambda(triple) (reduce-triple triple result-lists)) - (select-group construct)))) + (select-group construct)))) (defgeneric reduce-triple(construct result-lists) @@ -1155,6 +1165,7 @@ 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 @@ -1173,17 +1184,15 @@ (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))) + (loop for idx to (max 0 (1- (length var-elem))) + when (cond + ((stringp (elt var-elem idx)) + (find (elt var-elem idx) dont-touch-values :test #'string=)) + ((numberp (elt var-elem idx)) + (find (elt var-elem idx) dont-touch-values :test #'=)) + (t + (find (elt var-elem idx) dont-touch-values))) + collect idx)) (new-result-list (map 'list #'(lambda(row-idx) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Apr 3 15:56:15 2011 @@ -16,7 +16,8 @@ :unittests-constants :fixtures :d - :constants) + :constants + :tm-sparql-constants) (:export :run-sparql-tests :sparql-tests :test-prefix-and-base @@ -2075,14 +2076,105 @@ "}")) (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) (is-true (= (length r-1) 12)) - - (format t "~a~%" r-1)))) + (map 'list #'(lambda(item) + (cond ((string= (getf item :variable) "pred1") + ;one name without a type so it is not listed + (is (= (length (getf item :result)) 9))) + ((string= (getf item :variable) "pred2") + (is (= (length (getf item :result)) 3)) + (is-false (set-exclusive-or + (getf item :result) + (list (concat "<" *tms-role* ">") + (concat "<" *tms-reifier* ">")) + :test #'string=))) + ((string= (getf item :variable) "pred3") + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + (concat "<" *tms-player* ">")))) + ((string= (getf item :variable) "pred4") + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + (concat "<" *tms-value* ">")))) + ((string= (getf item :variable) "pred5") + (is (= (length (getf item :result)) 2)) + (is-false (set-exclusive-or + (getf item :result) + (list (concat "<" *tms-value* ">") + (concat "<" *tms-reifier* ">")) + :test #'string=))) + ((string= (getf item :variable) "pred6") + (is (= (length (getf item :result)) 2)) + (is-false (set-exclusive-or + (getf item :result) + (list (concat "<" *tms-value* ">") + (concat "<" *tms-scope* ">")) + :test #'string=))) + ((string= (getf item :variable) "obj1") + (is (= (length (getf item :result)) 9)) + (is-false (set-exclusive-or + (getf item :result) + (list "Johann Wolfgang" "von Goethe" + "28.08.1749" "22.03.1832" "82" + "true" "false" + "<http://some.where/tmsparql/author>" + "<http://some.where/psis/poem/zauberlehrling>") + :test #'string=))) + ((string= (getf item :variable) "obj2") + (is (= (length (getf item :result)) 3)) + (is-false + (set-exclusive-or + (getf item :result) + (list + "<http://some.where/ii/association-reifier>" + "<http://some.where/ii/role-2>" + (concat + "_:r" + (write-to-string + (elephant::oid + (loop for role in + (roles + (get-item-by-item-identifier + "http://some.where/ii/association" + :revision 0)) + when (string= + (uri (first (psis (player role + :revision 0)))) + "http://some.where/tmsparql/author/goethe") + return role))))) + :test #'string=))) + ((string= (getf item :variable) "obj3") + (is (= (length (getf item :result)) 1)) + (is (string= + (first (getf item :result)) + "<http://some.where/psis/poem/zauberlehrling>"))) + ((string= (getf item :variable) "obj4") + (is (= (length (getf item :result)) 1)) + (is (string= (first (getf item :result)) + "Johann Wolfgang von Goethe"))) + ((string= (getf item :variable) "obj5") + (is (= (length (getf item :result)) 2)) + (is-false + (set-exclusive-or + (getf item :result) + (list "28.08.1749" + "<http://some.where/ii/goethe-occ-reifier>") + :test #'string=))) + ((string= (getf item :variable) "obj6") + (is (= (length (getf item :result)) 2)) + (is-false + (set-exclusive-or + (getf item :result) + (list "Goethe" + "<http://some.where/tmsparql/display-name>") + :test #'string=))) + (t + (is-true (format t "bad variable-name found"))))) + r-1)))) ;TODO: complex filter, ; complex relations between variables -; <subj> ?pred ?obj, ; ?subj ?pred <obj> ;TODO: PREFIX tms:<http://www.networkedplanet.com/tmsparql/> ; SELECT * WHERE {

1 0