[isidorus-cvs] r367 - in trunk/src: TM-SPARQL base-tools unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Dec 16 21:07:41 UTC 2010
Author: lgiessmann
Date: Thu Dec 16 16:07:40 2010
New Revision: 367
Log:
TM-SPARQL: adde the hanlding of || and && operators; added also some unit-tests for these cases
Modified:
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/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp (original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp Thu Dec 16 16:07:40 2010
@@ -15,10 +15,19 @@
"Contains all supported SPARQL-functions")
-(defparameter *supported-operators*
- (list "!" "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/")
- "Contains all supported operators, note some unary operators
- are handled as functions, e.g. + and -")
+(defparameter *supported-binary-operators*
+ (list "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/")
+ "Contains all supported binary operators.")
+
+
+(defparameter *supported-unary-operators*
+ (list "!" "+" "-") "Contains all supported unary operators")
+
+
+(defun *supported-operators* ()
+ (union *supported-binary-operators* *supported-unary-operators*
+ :test #'string=))
+
(defparameter *supported-brackets*
(list "(" ")")
@@ -45,25 +54,115 @@
(let* ((result-set-boundings (set-boundings construct query-string))
(filter-string (getf result-set-boundings :filter-string))
(next-query (getf result-set-boundings :next-query))
- (filter-string-unary-ops (set-unary-operators construct filter-string))
+ (filter-string-unary-ops
+ (set-unary-operators construct filter-string))
+ (filter-string-or-and-ops
+ (set-or-and-operators construct filter-string-unary-ops))
))))
;;TODO: implement
- ;; *replace #comment => in set boundings
;; **replace () by (progn )
- ;; **replace ', """, ''' by '''
+ ;; **replace ', """, ''' by "
;; **replace !x by (not x)
;; **replace +x by (1+ x)
;; **replace -x by (1- x)
- ;; *replace x operator y by (filter-operator x y)
- ;; *=, !=, <, >, <=, >=, +, -, *, /, ||, &&
+ ;; **||, &&
+ ;; *=, !=, <, >, <=, >=, +, -, *, /
;; *replace function(x), function(x, y), function(x, y, z)
;; by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
- ;; check if all functions that will be invoked are allowed
- ;; add a let with all variables that are used: every variable with $ and ? prefix
- ;; add a let with (true t) and (false nil)
+ ;; *check if all functions that will be invoked are allowed
+ ;; *add a let with all variables that are used: every variable with $ and ? prefix
+ ;; *add a let with (true t) and (false nil)
+ ;; *embrace the final result uris in <> => unit-tests
;; *create and store this filter object
+(defgeneric set-or-and-operators (construct filter-string)
+ (:documentation "Transforms the || and && operators in the filter string to
+ the the lisp or and and functions.")
+ (:method ((construct SPARQL-Query) (filter-string String))
+ (let ((op-pos (search-first (list "||" "&&") filter-string)))
+ (if (not op-pos)
+ filter-string
+ (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
+ (left-str (subseq filter-string 0 op-pos))
+ (right-str (subseq filter-string (+ 2 op-pos)))
+ (left-scope (find-or-and-left-scope left-str))
+ (right-scope (find-or-and-right-scope right-str))
+ (modified-str
+ (concatenate 'string (subseq left-str 0 (- (length left-str)
+ (length left-scope)))
+ "(" (if (string= op-str "||") "or" "and") " "
+ "(progn " left-scope ")" "(progn " right-scope ")) "
+ (subseq right-str (length right-scope)))))
+ (set-or-and-operators construct modified-str))))))
+
+
+(defun find-binary-op-string (filter-string idx)
+ "Returns the operator as string that is placed on the position idx."
+ (let* ((2-ops
+ (remove-null (map 'list #'(lambda(op-string)
+ (when (= (length op-string) 2)
+ op-string))
+ *supported-binary-operators*)))
+ (operator-str (subseq filter-string idx)))
+ (if (string-starts-with-one-of operator-str 2-ops)
+ (subseq operator-str 0 2)
+ (subseq operator-str 0 1))))
+
+
+(defun find-or-and-left-scope (left-string)
+ "Returns the string that is the left part of the binary scope."
+ (declare (String left-string))
+ (let* ((first-bracket
+ (let ((inner-value (search-first-unclosed-paranthesis left-string)))
+ (when inner-value
+ (+ inner-value (1+ (length (name-after-paranthesis
+ (subseq left-string inner-value))))))))
+ (start-idx (if first-bracket
+ first-bracket
+ 0)))
+ (subseq left-string start-idx)))
+
+
+(defun name-after-paranthesis (str)
+ "Returns the substring that is contained after the paranthesis.
+ str must start with a ( otherwise the returnvalue is nil."
+ (declare (String str))
+ (let ((result "")
+ (non-whitespace-found nil))
+ (when (string-starts-with str "(")
+ (let ((cleaned-str (subseq str 1)))
+ (dotimes (idx (length cleaned-str))
+ (let ((current-char (subseq cleaned-str idx (1+ idx))))
+ (cond ((string-starts-with-one-of current-char (list "(" ")"))
+ (setf idx (length cleaned-str)))
+ ((and non-whitespace-found
+ (white-space-p current-char))
+ (setf idx (length cleaned-str)))
+ ((white-space-p current-char)
+ (push-string current-char result))
+ (t
+ (push-string current-char result)
+ (setf non-whitespace-found t)))))
+ result))))
+
+
+(defun find-or-and-right-scope (right-string)
+ "Returns the string that is the right part of the binary scope."
+ (declare (String right-string))
+ (let* ((first-pos (search-first (list "||" "&&") right-string))
+ (first-bracket
+ (let ((inner-value (search-first-unopened-paranthesis right-string)))
+ (when inner-value (1+ inner-value))))
+ (end-idx (cond ((and first-pos first-bracket)
+ (min first-pos first-bracket))
+ (first-pos first-pos)
+ (first-bracket first-bracket)
+ (t (if (= (length right-string) 0)
+ (1- (length right-string)))))))
+ (subseq right-string 0 end-idx)))
+
+
(defgeneric set-unary-operators (construct filter-string)
(:documentation "Transforms the unary operators !, +, - to (not ),
(1+ ) and (1- ). The return value is a modified filter
@@ -90,7 +189,7 @@
(if (or (string= string-before "")
(string-ends-with string-before "(progn")
(string-ends-with-one-of string-before
- *supported-operators*))
+ (*supported-operators*)))
(let ((result (unary-operator-scope filter-string idx)))
(push-string (concatenate 'string "(1" current-char " ")
result-string)
@@ -179,7 +278,7 @@
(declare (String str))
(when (or (string-starts-with str "?")
(string-starts-with str "$"))
- (let ((found-end (search-first (append (white-space) *supported-operators*
+ (let ((found-end (search-first (append (white-space) (*supported-operators*)
*supported-brackets* (list "?" "$"))
(subseq str 1))))
(if found-end
@@ -301,7 +400,7 @@
(Integer idx))
(let* ((delimiters (append (list " " (string #\Space) (string #\Tab)
(string #\Newline) (string #\cr) "(" ")")
- *supported-operators*))
+ (*supported-operators*)))
(string-before (trim-whitespace-right (subseq query-string 0 idx)))
(fragment-before-idx
(search-first delimiters string-before :from-end t))
@@ -323,7 +422,7 @@
(> (length fragment-before) (length operator)))
(setf fragment-before
(string-after fragment-before operator))))
- (append *supported-operators* *supported-brackets*)))
+ (append (*supported-operators*) *supported-brackets*)))
(if fragment-before
(progn
(when (or (string-starts-with fragment-before "?")
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Thu Dec 16 16:07:40 2010
@@ -12,6 +12,7 @@
(:nicknames :tools)
(:export :push-string
:when-do
+ :string-replace
:remove-null
:full-path
:trim-whitespace-left
@@ -21,6 +22,7 @@
:string-ends-with
:string-ends-with-one-of
:string-starts-with-char
+ :string-starts-with-one-of
:string-until
:string-after
:search-first
@@ -30,7 +32,10 @@
:string-after-number
:separate-leading-digits
:white-space
- :escape-string))
+ :white-space-p
+ :escape-string
+ :search-first-unclosed-paranthesis
+ :search-first-unopened-paranthesis ))
(in-package :base-tools)
@@ -63,6 +68,17 @@
nil)))
+(defun white-space-p (str)
+ "Returns t if the passed str contains only white space characters."
+ (cond ((and (= (length str) 1)
+ (string-starts-with-one-of str (white-space)))
+ t)
+ ((string-starts-with-one-of str (white-space))
+ (white-space-p (subseq str 1)))
+ (t
+ nil)))
+
+
(defun remove-null (lst)
"Removes all null values from the passed list."
(remove-if #'null lst))
@@ -118,6 +134,16 @@
(length str-i)))))
+(defun string-starts-with-one-of (str prefixes &key (ignore-case nil))
+ "Returns t if str ends with one of the string contained in suffixes."
+ (declare (String str)
+ (List prefixes)
+ (Boolean ignore-case))
+ (loop for prefix in prefixes
+ when (string-starts-with str prefix :ignore-case ignore-case)
+ return t))
+
+
(defun string-ends-with (str suffix &key (ignore-case nil))
"Checks if string str ends with a given suffix."
(declare (String str suffix)
@@ -146,6 +172,23 @@
return t))
+(defun string-replace (main-string string-to-replace new-string)
+ "Replaces every occurrence of string-to-replace by new-string
+ in main-string."
+ (declare (String main-string string-to-replace new-string))
+ (if (string= string-to-replace new-string)
+ main-string
+ (let ((search-idx (search-first (list string-to-replace) main-string)))
+ (if (not search-idx)
+ main-string
+ (let ((modified-string
+ (concatenate 'string (subseq main-string 0 search-idx)
+ new-string (subseq main-string
+ (+ search-idx (length string-to-replace))))))
+ (string-replace modified-string string-to-replace new-string))))))
+
+
+
(defun string-starts-with-digit (str)
"Checks whether the passed string starts with a digit."
(declare (String str))
@@ -153,6 +196,7 @@
when (string-starts-with str (write-to-string item))
return t))
+
(defun string-after-number (str)
"If str starts with a digit, there is returned the first
substring after a character that is a non-digit.
@@ -278,4 +322,41 @@
(push-string current-char result))
(t
(push-string current-char result)))))
- result))
\ No newline at end of file
+ result))
+
+
+(defun search-first-unclosed-paranthesis (str)
+ "Returns the idx of the first ( that is not closed, the search is
+ started from the end of the string."
+ (declare (String str))
+ (let ((r-str (reverse str))
+ (open-brackets 0)
+ (result-idx nil))
+ (dotimes (idx (length r-str))
+ (let ((current-char (subseq r-str idx (1+ idx))))
+ (cond ((string= current-char ")")
+ (decf open-brackets))
+ ((string= current-char "(")
+ (incf open-brackets)
+ (when (> open-brackets 0)
+ (setf result-idx idx)
+ (setf idx (length r-str)))))))
+ (when result-idx
+ (- (length str) (1+ result-idx)))))
+
+
+(defun search-first-unopened-paranthesis (str)
+ "Returns the idx of the first paranthesis that is not opened in str."
+ (declare (String str))
+ (let ((closed-brackets 0)
+ (result-idx nil))
+ (dotimes (idx (length str))
+ (let ((current-char (subseq str idx (1+ idx))))
+ (cond ((string= current-char "(")
+ (decf closed-brackets))
+ ((string= current-char ")")
+ (incf closed-brackets)
+ (when (> closed-brackets 0)
+ (setf result-idx idx)
+ (setf idx (length str)))))))
+ result-idx))
\ 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 Dec 16 16:07:40 2010
@@ -9,6 +9,7 @@
(defpackage :sparql-test
(:use :cl
+ :base-tools
:it.bese.FiveAM
:TM-SPARQL
:exceptions
@@ -31,7 +32,8 @@
:test-set-result-5
:test-result
:test-set-boundings
- :test-set-unary-operators))
+ :test-set-unary-operators
+ :test-set-or-and-operators))
(in-package :sparql-test)
@@ -1112,6 +1114,26 @@
(is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))))
+(test test-set-or-and-operators
+ "Tests various cases of the function set-unary-operators."
+ (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " "))
+ (str-1 "isLITERAL(STR(?var))||?var = 12 && true}")
+ (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}")
+ (result-1
+ (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+ (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1))
+ (result-2
+ (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+ (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2)))
+ (is-true result-1)
+ (is-true result-1-1)
+ (is-true result-2)
+ (is-true result-2-1)
+ (is (string= (string-replace result-1-1 " " "")
+ "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))"))
+ (is (string= (string-replace result-2-1 " " "")
+ "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))"))))
+
(defun run-sparql-tests ()
(it.bese.fiveam:run! 'sparql-test:sparql-tests))
More information about the Isidorus-cvs
mailing list