;;+-----------------------------------------------------------------------------
;;+  Isidorus
;;+  (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff
;;+
;;+  Isidorus is freely distributable under the LLGPL license.
;;+  You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and
;;+  trunk/docs/LGPL-LICENSE.txt.
;;+-----------------------------------------------------------------------------


(defpackage :filter-functions
  (:use :base-tools :constants :tm-sparql)
  (:import-from :cl progn handler-case let condition))


(defun filter-functions::normalize-value (value)
  "Returns the normalized value, i.e. if a literal
   is passed as '12'^^xsd:integer 12 is returned."
  (cond ((not (stringp value))
	 value)
	((or (base-tools:string-starts-with value "'")
	     (base-tools:string-starts-with value "\""))
	 (let* ((literal-result (tm-sparql::get-literal value))
		(literal-value
		 (cond ((or (base-tools:string-starts-with
			     (getf literal-result :literal) "\"\"\"")
			    (base-tools:string-starts-with
			     (getf literal-result :literal) "'''"))
			(subseq (getf literal-result :literal) 3
				(- (length (getf literal-result :literal)) 3)))
		       (t
			(subseq (getf literal-result :literal) 1
				(- (length (getf literal-result :literal)) 1)))))
		(given-datatype
		 (when (base-tools:string-starts-with
			(getf literal-result :next-string) "^^")
		   (subseq (getf literal-result :next-string) 2))))
	   (tm-sparql::cast-literal literal-value given-datatype)))
	(t
	 value)))


(defun filter-functions::not(x)
  (not (filter-functions::normalize-value x)))


(defun filter-functions::one+(x)
  (1+ (filter-functions::normalize-value x)))


(defun filter-functions::one-(x)
  (1- (filter-functions::normalize-value x)))


(defun filter-functions::+(x y)
  (+ (filter-functions::normalize-value x)
     (filter-functions::normalize-value y)))


(defun filter-functions::-(x y)
  (- (filter-functions::normalize-value x)
     (filter-functions::normalize-value y)))


(defun filter-functions::*(x y)
  (* (filter-functions::normalize-value x)
     (filter-functions::normalize-value y)))


(defun filter-functions::/(x y)
  (/ (filter-functions::normalize-value x)
     (filter-functions::normalize-value y)))


(defun filter-functions::or(x y)
  (or (filter-functions::normalize-value x)
      (filter-functions::normalize-value y)))


(defun filter-functions::and(x y)
  (and (filter-functions::normalize-value x)
       (filter-functions::normalize-value y)))


(defun filter-functions::=(x y)
  (let ((local-x (filter-functions::normalize-value x))
	(local-y (filter-functions::normalize-value y)))
    (cond ((and (stringp local-x) (stringp local-y))
	   (string= local-x local-y))
	  ((and (numberp local-x)( numberp local-y))
	   (= local-x local-y))
	  (t
	   (eql local-x local-y)))))


(defun filter-functions::!=(x y)
  (filter-functions::not
   (filter-functions::= x y)))


(defun filter-functions::<(x y)
  (let ((local-x (filter-functions::normalize-value x))
	(local-y (filter-functions::normalize-value y)))
    (cond ((and (numberp local-x) (numberp local-y))
	   (< local-x local-y))
	  ((and (stringp local-x) (stringp local-y))
	   (string< local-x local-y))
	  ((and (typep local-x 'Boolean) (typep local-y 'Boolean))
	   (and (not local-x) local-y))
	  (t
	   nil))))


(defun filter-functions::>(x y)
  (filter-functions::not
   (filter-functions::< x y)))


(defun filter-functions::<=(x y)
  (filter-functions::or
   (filter-functions::< x y)
   (filter-functions::= x y)))


(defun filter-functions::>=(x y)
  (filter-functions::or
   (filter-functions::> x y)
   (filter-functions::= x y)))
	   

(defun filter-functions::regex(str pattern &optional flags)
  (let* ((local-str (filter-functions::normalize-value str))
	 (local-flags (filter-functions::normalize-value flags))
	 (case-insensitive (when (find #\i local-flags) t))
	 (multi-line (when (find #\m local-flags) t))
	 (single-line (when (find #\s local-flags) t))
	 (local-pattern
	  (if (find #\x local-flags)
	      (base-tools:string-replace
	       (base-tools:string-replace
		(base-tools:string-replace
		 (base-tools:string-replace
		  (filter-functions::normalize-value pattern)
		  (string #\newline) "")
		 (string #\tab) "") (string #\cr) "") " " "")
	      (filter-functions::normalize-value pattern)))
	 (scanner
	  (ppcre:create-scanner local-pattern
				:case-insensitive-mode case-insensitive
				:multi-line-mode multi-line
				:single-line-mode single-line)))
    (when (ppcre:scan scanner local-str)
      t)))


(defun filter-functions::write-to-symbol (name-string)
  (common-lisp:intern (common-lisp:string-upcase name-string)))


(defun filter-functions::bound(x)
  (boundp (filter-functions::write-to-symbol x)))


(defun filter-functions::isLITERAL(x)
  (or (numberp x)
      (not (and (base-tools:string-starts-with x "<")
		(base-tools:string-ends-with x ">")
		(base-tools:absolute-uri-p x)))))


(defun filter-functions::datatype(x)
  (let ((type-suffix
	 (when (and (stringp x)
		    (or (base-tools:string-starts-with x "'")
			(base-tools:string-starts-with x "\"")))
	   (let* ((result (base-tools:get-literal x))
		  (literal-datatype
		   (when (base-tools:string-starts-with
			  (getf result :next-string) "^^")
		     (subseq (getf result :next-string) 2))))
	     literal-datatype))))
    (cond (type-suffix type-suffix)
	  ((integerp x) constants::*xml-integer*)
	  ((floatp x) constants::*xml-decimal*)
	  ((typep x 'double-float) constants::*xml-double*)
	  ((stringp x) constants::*xml-string*)
	  (t (type-of x)))))


(defun filter-functions::str(x)
   (write-to-string x))