(in-package :cl-user) ;; http://jena.sourceforge.net/ontology/index.html ;; http://jena.sourceforge.net/how-to/model-factory.html ;; INSERT and other mutating commands: ;; http://jena.hpl.hp.com/~afs/SPARQL-Update.html (defvar *include-reasoning-prefix*) (defvar *sparql-using-pellet* nil) (defvar *sparql-namespace-uses* nil) (defvar *sparql-allow-trace* t) (defvar *sparql-always-trace* nil) (defun sparql-endpoint-query (url query &key query-options geturl-options (command :query)) (let ((results (find-elements-with-tag (xmls::parse (apply 'get-url (if (uri-p url) (uri-full url) url) :post (append `(("query" ,query ) ("format" "application/sparql-results+xml") ,@(if (eq command :query) '(("should-sponge" "soft")))) query-options) (append geturl-options (list :dont-cache t :force-refetch t )))) "result"))) (loop for result in results collect (loop for binding in (find-elements-with-tag result "binding" ) collect (cond ((equal (caar (third binding)) "uri") (make-uri (third (third binding)))) ((equal (caar (third binding)) "bnode") (if (eql 0 (search "nodeID://" (third (third binding)))) (make-uri (third (third binding))) ;; hack for virtuoso, since we can then use them in queries as is. (make-uri (format nil "~a~a" *blankprefix* (#"replaceAll" (format nil "~a~a" (uri-full url) (third (third binding))) "://" "_"))))) ((member (caar (third binding)) '("literal" "string") :test 'equal) (third (third binding))) (t (read-from-string (third (third binding))))) )))) (defvar *default-reasoner* :pellet) (defvar *endpoint-abbreviations* nil) ;; http://www-128.ibm.com/developerworks/xml/library/j-sparql/ (defun sparql (query &key (kb *default-kb*) (use-reasoner *default-reasoner*) (flatten nil) (trace nil) (trace-show-query trace) endpoint-options geturl-options (values t) &aux (command :query) count) (setq count (and (consp query) (eq (car query) :select) (getf (third query) :count) (member use-reasoner '(:jena :none :pellet)))) (when (typep kb 'owl-ontology) (setq kb (kb kb))) (when (listp query) (setq command (car query)) (setq query (sparql-stringify query use-reasoner))) (setq use-reasoner (or (second (assoc use-reasoner *endpoint-abbreviations*)) use-reasoner)) (if (stringp use-reasoner) (setq use-reasoner (make-uri use-reasoner))) (let ((do-trace (or *sparql-always-trace* (and trace *sparql-allow-trace*)))) (if (and do-trace trace-show-query) (format t "Query: ~a~%~a~%Results:~%" (or trace "Tracing all") query) (if do-trace (format t "Query: ~a~%Results:~%" (or trace "Tracing all")))) (if (uri-p use-reasoner) (let ((bindings (sparql-endpoint-query use-reasoner query :query-options endpoint-options :geturl-options geturl-options :command command))) (when do-trace (loop for one in bindings do (format t "~{~s~^ ~}~%" one)) (terpri t)) bindings) (let* ( ;; Query query = QueryFactory.create(queryString); (jquery (#"create" 'QueryFactory query (#"lookup" 'Syntax "SPARQL"))) ;; Execute the query and obtain results ;; QueryExecution qe = QueryExecutionFactory.create(query, model); (qe (cond ((or (eq use-reasoner :pellet ) (eq use-reasoner t)) (new 'PelletQueryExecution jquery (kb-jena-model kb))) ((or (eq use-reasoner :none) (eq use-reasoner nil)) (#"create" 'QueryExecutionFactory jquery (#"getModel" (kb-jena-reasoner kb)))) ((or (eq use-reasoner :jena)) (#"create" 'QueryExecutionFactory jquery (kb-jena-model kb))) ((eq use-reasoner :owl) (#"create" 'QueryExecutionFactory jquery (#"createInfModel" 'modelfactory (#"getOWLReasoner" 'ReasonerRegistry) (#"getModel" (kb-jena-reasoner kb))))))) ;; ResultSet results = qe.execSelect(); (vars (set-to-list (#"getResultVars" jquery)))) (unwind-protect (with-constant-signature ((getv "get") (next "next") (has-next "hasNext") (get-uri "getURI")) (flet ((get-vars (bindingset) (let ((bindings (loop for var in vars for jval = (getv bindingset var) for val = (if (null jval) nil (if (#"isResource" jval) (make-uri (or (get-uri jval) (format nil "~a~a" *blankprefix* (#"toString" jval)) )) (#"getValue" jval))) collect val))) (when do-trace (format t "~{~s~^ ~}~%" bindings)) bindings))) ; (when (and (eq use-reasoner :pellet) query-uses-blank-nodes) ; (set-java-field 'PelletOptions "TREAT_ALL_VARS_DISTINGUISHED" nil)) (when (kb-kb kb) (#"realize" (kb-kb kb))) ; work around pellet bug (let ((results (if (eq use-reasoner :pellet) (#"execQuery" (kb-jena-reasoner kb) jquery) (#"execSelect" qe)))) (if count (return-from sparql (loop while (has-next results) do (next results) sum 1))) (if values (if flatten (loop while (has-next results) append (get-vars (next results))) (loop while (has-next results) collect (get-vars (next results)))) (loop while (has-next results) do (get-vars (next results)) finally (return (values)) ) )))) ;; Important - free up resources used running the query ;; qe.close(); (#"close" qe) (if do-trace (terpri)) ))))) (defun class-apropos (string &optional (kb *default-kb*) (trace t) (trace-show-query nil)) (let ((re (format nil ".*~a.*" string))) (sparql `(:select (?thing ?label) (:distinct t) (?thing ,!rdfs:subClassOf ,!owl:Thing) (:optional (?thing !rdfs:label ?label)) (:filter (or (regex (str ?thing) ,re "i") (regex (str ?label) ,re "i")))) :kb kb :use-reasoner :jena :trace (if (eq trace t) (format nil "Classes matching ~a" re)) :trace-show-query trace-show-query)) (if trace nil (mapcar 'car res))) (defun property-apropos (string &optional (kb *default-kb*) (trace t) (trace-show-query nil)) (let ((res (sparql `(:select (?p ?label) (:distinct p) (:union ((?p !rdf:type !owl:ObjectProperty)) ((?p !rdf:type !owl:DatatypePropery)) ((?p !rdf:type !owl:AnnotationProperty)) ((?s ?p ?o))) (:optional (?p !rdfs:label ?label)) (:filter (or (regex (str ?label) ,(format nil ".*~a.*" string) "i") (regex (str ?p) ,(format nil ".*~a.*" string) "i"))) ) :kb kb :use-reasoner :none :trace (if (eq trace t) "Properties") :trace-show-query trace-show-query))) (if trace nil (mapcar 'car res)))) (defun string-query-uses-blank-nodes (query) (or (find #\[ query) (search query "_:"))) (defun list-query-uses-blank-nodes (query) (cond ((eq query '[]) t) ((keywordp query) (char= (char (string query) 0) #\_)) ((consp query) (or (list-query-uses-blank-nodes (car query)) (list-query-uses-blank-nodes (cdr query)))))) (defun sparql-stringify (form &optional reasoner &rest ignore) (let ((*sparql-using-pellet* (eq reasoner :pellet)) (*sparql-namespace-uses* nil) (*include-reasoning-prefix* nil) query) (setq form (eval-uri-reader-macro form)) (setq query ;; DELETE and INSERT can take WHERE clauses, not supported here yet (cond ((eq (car form) :insert) (destructuring-bind ((&key from) &rest clauses) (cdr form) (with-output-to-string (s) (format s "INSERT ~A { " (if from (format nil "INTO GRAPH <~A>" (uri-full from)) "")) (loop for clause in (cddr form) do (emit-sparql-clause clause s)) (format s " }")))) ((eq (car form) :delete) (destructuring-bind ((&key from) &rest clauses) (cdr form) (with-output-to-string (s) (format s "DELETE ~A { " (if from (format nil "FROM GRAPH <~A>" (uri-full from)) "")) (loop for clause in (cddr form) do (emit-sparql-clause clause s)) (format s " }")))) ((eq (car form) :select) (destructuring-bind (vars (&key limit distinct from count) &rest clauses) (cdr form) (with-output-to-string (s) (let ((*print-case* :downcase)) (format s "SELECT ~a~a~{~a~^ ~}~a~a~%WHERE { " (if (and count (not (member reasoner '(:jena :none :pellet)))) "COUNT(" "") (if distinct "DISTINCT " "") vars (if (and count (not (member reasoner '(:jena :none :pellet)))) ")" "") (if from (format nil "~{ FROM <~a> ~^~%~}" (mapcar 'uri-full (if (atom from) (list from) from))) "") ) (loop for clause in clauses do (emit-sparql-clause clause s)) (format s "} ~a" (if limit (format nil "LIMIT ~a " limit) "")))))) (t (error "Can't handle ~A command yet" (car form))))) ;; add prefixes (let* ((*nslookup* (mapcar 'reverse *namespace-replacements*)) (prefix (with-output-to-string (p) (loop for ns in *sparql-namespace-uses* do (format p "PREFIX ~a <~a>~%" ns (second (assoc ns *nslookup* :test 'equal))))))) (setq query (concatenate 'string prefix query )) ;; magic? (if (search "reasoning:" query) (format nil "PREFIX reasoning: ~%~a" query) query)) )) (defvar *bnode-name-counter* 0) (defun emit-blank-node (name stream) (if (eq name '[]) (format stream "[]") (let ((name (subseq (string name) 1))) (if (equal name "") (emit-blank-node '[] stream) (concatenate 'string "_:" name))))) (defun emit-sparql-clause (clause s) (flet ((maybe-format-uri (el) (cond ((eq el :a) "a") ((eq el '[]) (emit-blank-node '[] nil)) ((and (keywordp el) (char= (char (string el) 0) #\_)) (emit-blank-node el nil)) ((equal el "") "\"\"") ((uri-p el) (multiple-value-bind (string ns) (maybe-abbreviate-namespace (uri-full el) :sparql) (if ns (progn (pushnew ns *sparql-namespace-uses* :test 'equal) string) (format nil "<~a>" (uri-full el))))) ((and (stringp el) (char= (char el 0) #\<) (char= (char el (1- (length el))) #\>)) el) (t (let ((transformed (maybe-unabbreviate-namespace el))) (if (eq el transformed) (cond ((stringp el) (format nil "~s" el)) ((and (integerp el) (minusp el)) (format nil "\"~A\"^^" el)) (t el)) (format nil "<~a>" transformed))))))) (cond ((eq (car clause) :optional) (format s "~%OPTIONAL { ") (loop for sub in (cdr clause) do (funcall 'emit-sparql-clause sub s)) (format s "}.")) ((eq (car clause) :union) (loop for (sub more) on (cdr clause) do (format s "~% { ") (mapcar (lambda(c) (emit-sparql-clause c s)) sub) (write-string "}" s) (when more (write-string " UNION " s))) (write-string "." s)) ((eq (car clause) :filter) (format s "~%FILTER ") (emit-sparql-filter (second clause) s)) (t (apply 'format s "~%~a ~a ~a . " (mapcar #'maybe-format-uri clause)))))) (defparameter *sparql-function-names* '((is-canonical "reasoning:isCanonical") (isiri "isIRI") )) ; (defun emit-sparql-filter (expression s) (let ((*print-case* :downcase)) (cond ((and (consp expression) (assoc (car expression) '((and "&&")(or "||") (equal "=") (< "<") (> ">")))) (write-char #\( s) (loop for rest on (cdr expression) do (emit-sparql-filter (car rest) s) (when (cdr rest) (format s " ~a " (second (assoc (car expression) '((and "&&")(or "||") (equal "=") (< "<") (> ">"))))))) (write-char #\) s)) ((and (consp expression) (eq (car expression) 'not)) (write-string "(!(" s) (loop for arg in (cdr expression) do (emit-sparql-filter arg s)) (write-string "))" s)) ((and (keywordp expression) (char= (char (string expression) 0) #\_)) (emit-blank-node expression s)) ((uri-p expression) (format s " <~a> " (uri-full expression))) ;; MT tentative addition -- try to get FILTER clause in right format (still requires Jena) ((or (stringp expression) (numberp expression)) (format s "~s" expression)) (t (if (atom expression) (if (stringp expression) (format s "~s" expression) (princ (string-downcase (string expression)) s)) (progn (format s "~a(" (or (second (assoc (car expression) *sparql-function-names*)) (car expression))) (loop for rest on (cdr expression) do (emit-sparql-filter (car rest) s) (when (cdr rest) (write-char #\, s))) (write-char #\) s))))))) (defun vinspect (object &optional (graphs (list !))) (make-instance 'rdf-inspector :reasoner ! :from-graphs graphs :object object :show-inverse t)) (eval-when (:load-toplevel :execute) (when (find-java-class 'IsCanonical) (#"put" (#"get" 'FunctionRegistry) "http://www.mindswap.org/2005/sparql/reasoning#isCanonical" (find-java-class 'IsCanonical))))