(in-package :cl-user)

#|
Two things:

1) A clos wrapper for an ontology, and a construction function define-ontology.

2) Assertions are given in a trivial transformation of abstract syntax to lisp syntax.

URIs are read with "!" reader macro. See uri.lisp.

*namespace-replacements* is mapping of abbreviation to full
 name (that's where you put expansions for "ex:" etc.

1) CamelCase -> camel-case
2) prefix instead of infix "Class(ex:foo)" -> (class !ex:foo)

e.g

(define-ontology biopax-level2 (:base "bp2:")
  (class !entity))

(abstract-syntax biopax-level2)
=> "Ontology(<http://www.biopax.org/release/biopax-level2.owl#> Class(<http://www.biopax.org/release/biopax-level2.owl#entity> )
)"

If you don't specify a base, then the base is http://example.com/ aka "ex:"

Generic Functions:

abstract-syntax:  returns abstract syntax as a string
rdfxml: returns rdf/xml as a string
kb: returns a pellet kb for the ontology
check: runs check-abox-consistency on the ontology
pprint-ontology: pprints the lisp syntax form of the ontology

|#

(defclass owl-ontology ()
  ((sexp-source :initarg :sexp-source :initform nil :accessor sexp-source)
   (includes :initarg :includes :initform nil :accessor includes)
   (abstract-syntax :initarg :abstract-syntax :initform nil :accessor abstract-syntax)
   (rdfxml :initarg :rdfxml :initform nil :accessor rdfxml)
   (name :initarg :name :initform nil :accessor name)
   (base :initarg :base :initform nil :accessor base)
   (about :initarg :about :initform nil :accessor about)
   (kb :initarg :kb :initform nil :accessor kb)
   (modification-stamp :initarg :modification-stamp :initform nil :accessor modification-stamp)
   (modification-counter  :initform 0 :accessor modification-counter :allocation :class)
   (rules :initarg :rules :initform nil :accessor rules)
   (srules :initarg :srules :initform nil :accessor srules)
   (load-using :initarg :load-using :initform :jena :accessor load-using)
   ))

(defmethod includes :around ((o owl-ontology))
  (let ((this (call-next-method))
	(all nil))
    (loop for o in this
	 do
	 (unless (and o (member o all))
	   (setq all (append (includes (symbol-value o)) all))))
    (append all this)))

(defmethod initialize-instance :after ((o owl-ontology) &key)
  (setf (modification-stamp o) (incf (modification-counter o))))

(defmethod pprint-ontology ((o owl-ontology))
  (let ((*print-case* :downcase))
    (pprint (sexp-source o))))

(defmethod print-rules ((o owl-ontology))
  (mapcar #"toString" (rules o)))

(defmethod print-object ((o owl-ontology) stream)
  (print-unreadable-object (o stream)
    (format stream "Ontology ~a at ~a" (string-downcase (string (name o))) (base o))))

(defmethod as-turtle ((ont owl-ontology))
  (as-turtle (kb ont)))

#||
;Apparently extraneous material left by AR in file by accident. -JAR
  (let ((sw (new 'stringwriter))) (#"write" (kb-jena-model kb) sw "TURTLE") (#"toString" sw)))
||#

(defpackage owl-internal (:use))

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defparameter *owl-keyword-to-string* (make-hash-table))
  (defparameter *owl-string-to-function* (make-hash-table :test 'equal))
  (defparameter *owl-keyword-terms* (make-hash-table :test 'equal))

  (defun define-owl-term-internal (term arglist)
    (let* ((explicit-keyword (if (and (consp term) (third term)) (third term))) 
	   (explicit-fname (if (consp term) (prog1 (second term) (setq term (car term)))))
	   (symbol-name (coerce (cons (char-upcase (char term 0))
				      (loop for char across (subseq term 1)
					 if (char= char (char-upcase char))
					 collect #\-
					 collect (char-upcase char))) 'string))
	   (fname (or explicit-fname (intern symbol-name)))
	   (internal-fname (intern (string fname) 'owl-internal))
	   (keyword (intern (or (and explicit-keyword (string explicit-keyword))
				(and explicit-fname (string explicit-fname))
				 symbol-name) 'keyword)))
    
      `(progn
	 (setf (gethash ,keyword *owl-keyword-to-string*) ,term)
	 (setf (gethash ,term *owl-string-to-function*) ',fname)
	 ,(if arglist
	      `(progn
		(defun ,internal-fname ,arglist
		   ,(if (member '&rest arglist)
			`(list* ,keyword ,@(remove '&rest arglist))
			`(list ,keyword ,@arglist)))
		(defun ,fname (&rest args) (apply ',internal-fname args)))
	      `(setf (gethash ',term *owl-keyword-terms*) ,keyword)))))

  (defmacro define-owl-term (term &optional arglist)
    (define-owl-term-internal term arglist)))

(define-owl-term "Ontology" (name ontology-properties &rest assertions))
(define-owl-term "Class" (name &rest aspects))
(define-owl-term "DeprecatedClass" (name &rest aspects))
(define-owl-term "DisjointClasses" (&rest classes))
(define-owl-term "EquivalentClasses" (&rest classes))
(define-owl-term "DifferentIndividuals" (&rest individuals))
(define-owl-term "SameIndividual" (&rest individuals))
(define-owl-term "SubClassOf" (sub super))
(define-owl-term "ObjectProperty" (name &rest aspects))
(define-owl-term "DatatypeProperty" (name &rest aspects))
(define-owl-term "AnnotationProperty" (name &rest annotations))
(define-owl-term "OntologyProperty" (name &rest annotations))
(define-owl-term "EquivalentProperties" (name &rest properties))
(define-owl-term "SubPropertyOf" (sub super))
(define-owl-term "inverseOf" (property))
(define-owl-term "restriction" (property expression))
(define-owl-term "allValuesFrom" (class))
(define-owl-term "someValuesFrom" (class))
;; this is an annoyance - value means hasValue and also property value. Need to fix owl-to-lisp to handle properly
(define-owl-term ("value" has-value :value) (value))
(define-owl-term "EnumeratedClass" (name &rest individuals))
(define-owl-term "cardinality" (card))
(define-owl-term "maxCardinality" (card))
(define-owl-term "minCardinality" (card))
(define-owl-term "domain" (class))
(define-owl-term "range" (class))
(define-owl-term "oneOf" (&rest individuals))
(define-owl-term "unionOf" (&rest classes))
(define-owl-term "intersectionOf" (&rest classes))
(define-owl-term "complementOf" (&rest class))
(define-owl-term "type" (class))
(define-owl-term "Individual" (name &rest aspects))
(define-owl-term "value" (property value))
(define-owl-term "annotation" (property value))
(define-owl-term ("Annotation" ontology-annotation) (property value))
(define-owl-term "InverseFunctional")
(define-owl-term "Functional")
(define-owl-term "Transitive")
(define-owl-term "Symmetric")
(define-owl-term "Deprecated")
(define-owl-term "super" (superproperty))
(define-owl-term "partial")
(define-owl-term "complete")


(defun literal (value-as-string type)
  `(:literal ,value-as-string ,type))

(defun ontology-annotation (property value)
  (or (and (equal property !owl:imports)
	   (let ((found (maybe-redirect-owl-import value)))
	     (and found (owl-internal::ontology-annotation property found))))
      (owl-internal::ontology-annotation property value)))

(defvar *flatten-class-intersections* nil
  "If t then flatten intersections into a serials of (class partial foo) forms. Useful for some simplifications of stuff heading to an rdf store")

(defvar *ignore-expression-supers* nil
  "Might be useful for troublesome ontologies that won't classify. Ignore any class supers other than named classes")

(defun class (&rest args)
  (assert (or (member :partial args :test 'equal) (member :complete args :test 'equal)) (args)
	  "Forgot :partial or :complete in ~a" `(class ,@args))
  (loop for arg in args  
     if (stringp arg) collect arg into comments
     else if (and (consp arg) (eq (car arg) :annotation)) collect  arg into annots
     else when arg collect arg into real
     finally
       (let ((supers 
	      (if (and (uri-p (first real))
		       (or *flatten-class-intersections* *ignore-expression-supers*)
		       (member :partial args)) ; don't do this for complete - it is wrong.
		  (flatten-intersections (cddr real))
		  (cond ((null (cddr real)) nil)
			((= (length (cddr real)) 1) (cddr real))
			(t (list (apply 'intersection-of (cddr real))))))))
	 (return 
	   (cons 
	    (if comments
		(apply 'owl-internal::class 
		       (append (list* (first real) 
				      :partial
				      (annotation !rdfs:comment (format nil "~{~a~^; ~}" comments))
				      annots)
			))
		(and annots
		     (apply 'owl-internal::class
			    (append 
			     (list*
			      (first real) 
			      :partial
			      annots)
			     ))))
	   (loop for super in supers 
	      unless (and *ignore-expression-supers* (consp super))
	      collect
		(owl-internal::class (first real) (second real) super)
		))))))

(defun flatten-intersections (supers)
  (loop for super in supers
     if (and (consp super) 
	     (equal (car super) :intersection-of))
     append (flatten-intersections (cdr super))
     else collect super))


(defvar *blankcounter* 0)

(defvar *name-blanks* t)

(defun individual (&rest args)
  (loop for arg in args 
     if (stringp arg) collect arg into comments
     else if (and (consp arg) (eq (car arg) :annotation)) collect arg into annots
     else collect arg into real
     finally (return 
	       (progn
		 (when (not (uri-p (car real)))
		   (if *name-blanks* 
		       (push (make-uri (format nil "~a~a" *blankprefix* (incf *blankcounter*))) real)
		       (push nil real)))
		 (if comments
		     (apply 'owl-internal::individual (first real) 
			    (annotation !rdfs:comment (format nil "~{~a~^; ~}" comments))
			    (append annots (cdr real)))
		     (apply 'owl-internal::individual  (first real) (append annots (cdr real))))))))

(defun object-property (&rest args)
  (loop for arg in args 
     if (stringp arg) collect arg into comments
     else collect arg into real
     finally (return			;(print-db args comments real)
	       (if comments
		   (apply 'owl-internal::object-property
			  (first real) 
			  (annotation !rdfs:comment (format nil "~{~a~^; ~}" comments))
			  (reorder-property-args (cdr real)))
		   (apply 'owl-internal::object-property
			  (first real)
			  (reorder-property-args (cdr real)))))))

(defun reorder-property-args (args)
  (sort args '< :key (lambda(el)
		       (cond ((keywordp el)
			      (case el
				(:symmetric 2.1)
				(:functional 2.2)
				(:inverse-functional 2.4)
				(:transitive 2.4)
				(otherwise 2)))
			     ((eq (car el) :super) 0)
			     ((eq (car el) :annotation) -.1)
			     ((eq (car el) :inverse-of) 1)
			     ((eq (car el) :domain) 3)
			     ((eq (car el) :range) 4)
			     ((null el) 0)))))

(defun ontology-property (&rest args)
  (loop for arg in args 
     if (stringp arg) collect arg into comments
     else collect arg into real
     finally (return 
	       (if comments
		   (apply 'owl-internal::ontology-property (first real) 
			  (annotation !rdfs:comment (format nil "~{~a~^; ~}" comments)) (cdr real))
		   (apply 'owl-internal::ontology-property real)))))

(defun datatype-property (&rest args)
  (loop for arg in args 
     if (stringp arg) collect arg into comments
     else collect arg into real
       finally (return 
		 (if comments
		     (apply 'owl-internal::datatype-property
			    (first real) 
			    (annotation !rdfs:comment (format nil "~{~a~^; ~}" comments))
			    (reorder-property-args (cdr real)))
		     (apply 'owl-internal::datatype-property
			    (first real)
			    (reorder-property-args (cdr real)))))))

(defmethod xsd-literal-form-of ((thing t))
  (error "Don't know how to make ~a into a literal" thing))

(defun value (property value)
  (cond ((stringp value)
	 (when (#"matches" value ".*\\\\.*")
	   (print-db value)
	   (setq value (#"replaceAll" value "\\\\" "\\\\\\\\"))
	   (print-db value))
	 (owl-internal::value property (literal value !xsd:string)))
	((and (consp value)
	      (eq (car value) :literal))
	 (owl-internal::value property value))
	((integerp value)
	 (owl-internal::value property (literal (princ-to-string value) !xsd:int)))
	((floatp value)
	 (owl-internal::value property (literal (princ-to-string value) !xsd:float)))
	((uri-p value)
	 (owl-internal::value property value))
	((and (consp value)
	      (eq (car value) :individual))
	 (owl-internal::value property value))
	(t
	 (owl-internal::value property (xsd-literal-form-of value)))))

(defun has-value (value)
  (cond ((stringp value)
	 (owl-internal::has-value (literal value !xsd:string)))
	((and (consp value)
	      (eq (car value) :literal))
	 (owl-internal::has-value value))
	((integerp value)
	 (owl-internal::has-value (literal (princ-to-string value) !xsd:int)))
	((floatp value)
	 (owl-internal::has-value (literal (princ-to-string value) !xsd:float)))
	((uri-p value)
	 (owl-internal::has-value value))
	(t
	 (owl-internal::has-value (xsd-literal-form-of value)))))

(defvar *warn-on-annotation-string-lossage* t)

(defun safe-annotation-string (value property)
  (if (search "future" value) (setq @ value))
  (when (find #\" value)
    (when *warn-on-annotation-string-lossage*
      (format *debug-io* "Changing quote to single quote in: ~a:~a~%" property value))
    (setq value (#"replaceAll" value "(?s)\"" "'")))
  ;; smart quote lossage
  (when (#"matches" value "(?s).*(\\x18|\\x19|\\u2018|\\u2019).*")
    (when *warn-on-annotation-string-lossage*
      (format *debug-io* "Removing 'smart quotes' in ~a:~a~%" property value))
    (setq value (#"replaceAll" value "(?s)(\\x18|\\x19|\\u2018|\\u2019)" "'")))
   (when (find #\\ value)
     (when *warn-on-annotation-string-lossage*
       (format *debug-io* "Removing backslash in: ~a:~a~%" property value))
     (setq value (#"replaceAll" value "(?s)[\\\\]" "")))
   (when (and (char= (char value (1- (length value))) #\\)
	      (not (char= (char value (- (length value) 2)) #\\)))
     (when *warn-on-annotation-string-lossage* 
       (format *debug-io* "removing trailing backslash in ~a:~a~%" property value))
     (setq value (subseq value 0 (- (length value) 2)))
     (setq value (#"replaceAll" value "(?s)\\$" "")))
   value)

(defun annotation (property value)
  (cond ((equal value "") nil)
	((stringp value)
	 (owl-internal::annotation property (literal (safe-annotation-string value property) !xsd:string)))
	((and (consp value)
	      (eq (car value) :literal))
	 (owl-internal::annotation property value))
	((integerp value)
	 (owl-internal::annotation property (literal (princ-to-string value) !xsd:int)))
	((floatp value)
	 (owl-internal::annotation property (literal (princ-to-string value) !xsd:float)))
	((uri-p value)
	 (owl-internal::annotation property value))
	((and (consp value)
	      (eq (car value) :individual))
	 (owl-internal::annotation property value))
	(t
	 (owl-internal::annotation property (xsd-literal-form-of value)))))


	      

(defvar *owl-redirect-import-functions* '(owl-redirect-from-alist))

(defun maybe-redirect-owl-import (where)
  (loop for fn in *owl-redirect-import-functions* 
     for new =  (funcall fn where)
     when new do (return-from maybe-redirect-owl-import (make-uri new))))

(defvar *owl-redirects-alist* nil)

(defun owl-redirect-from-alist (where)
  (second (assoc (if (uri-p where) (uri-full where) where) *owl-redirects-alist*  :test 'equal)))

(defmacro with-import-redirect (from to &body body)
  `(let ((*owl-redirects-alist* (cons (list ,from (maybe-url-filename ,to)) *owl-redirects-alist*)))
    ,@body))

(defvar *abstract-syntax-namespaces* nil)

(defun dwim-owl-literal (literal)
  (cond ((integerp literal)
	 (literal literal !xsd:int))
	((floatp literal)
	 (literal literal !xsd:float))
	(t (error "Don't know what to do with literal ~a" literal))))


(defun owl-prefix-to-infix (owl-sexp stream)
  (cond ((and (java-object-p owl-sexp)
	      (equal
	       (jclass-name (jobject-class owl-sexp))
	       "org.semanticweb.owl.impl.rules.OWLRuleImpl"))
	 )
	((uri-p owl-sexp)
	 (multiple-value-bind (abbrev ns) (maybe-abbreviate-namespace (uri-full owl-sexp) :absowl)
	   (if ns
	       (progn (format stream "~a " abbrev) (pushnew ns *abstract-syntax-namespaces* :test 'equal))
	       (format stream "<~a> " (uri-full owl-sexp)))))
	((null owl-sexp))
	((symbolp owl-sexp)
	 (write-string (gethash owl-sexp *owl-keyword-to-string*) stream)
	 (write-char #\space stream))
	((atom owl-sexp)
	 (prin1 owl-sexp stream))
	((and (consp owl-sexp)
	      (eq (car owl-sexp) :literal))
	 (if (keywordp (third owl-sexp))
	     (format stream "\"~a\"\@~a" (second owl-sexp) (subseq (string (third owl-sexp)) 1))
	     (format stream "\"~a\"^^<~a>" (second owl-sexp) (uri-full (third owl-sexp)))))
	((listp (car owl-sexp))
	 (map nil (lambda(el) (owl-prefix-to-infix el stream)) owl-sexp))
	((and (consp owl-sexp)
	      (member (car owl-sexp) '(:intersection-of :union-of))
	      (<= (length owl-sexp) 2))
	 (owl-prefix-to-infix (second owl-sexp) stream))
	(t 
	 (let ((fterm (gethash (car owl-sexp) *owl-keyword-to-string*)))
	   (write-string fterm stream)
	   (write-string "(" stream)
	   (map nil (lambda(el) (owl-prefix-to-infix el stream)) (rest owl-sexp))
	   (write-string ")" stream)
	   (when (upper-case-p (char fterm 0))
	     (terpri stream))))))

(defmethod decache ((o owl-ontology))
  (setf (abstract-syntax o) nil)
  (setf (kb o) nil)
  (setf (rdfxml o) nil))
  

(defmethod something-i-depend-on-changed ((o owl-ontology))
   (< (modification-stamp o)
      (apply 'max 0 (mapcar (lambda(s) (modification-stamp (symbol-value s))) (includes o)))))

(defmethod abstract-syntax :around ((o owl-ontology))
  (or (and  (not (something-i-depend-on-changed o)) (call-next-method))
      (progn
	(setf (abstract-syntax o) 
	      (let ((*abstract-syntax-namespaces* nil))
		(let ((body (with-output-to-string (s)
			      (owl-prefix-to-infix 
			       (list (first (sexp-source o))
				     (second (sexp-source o))
				     (third (sexp-source o))
				     (mapcar (lambda(i) (cdddr (sexp-source (eval i)))) (mapcar 'symbol-value (includes o)))
				     (cdddr (sexp-source o)))
			       s))))
					;Namespace(a	= <http://example.com/#>)

		  (let* ((*nslookup* (mapcar 'reverse *namespace-replacements*)))
		    (with-output-to-string (p)
		      (loop for ns in *abstract-syntax-namespaces*
			 do (format p "Namespace(~a = <~a>)~%" 
				    (subseq ns 0 (1- (length ns)))
				    (second (assoc ns *nslookup* :test 'equal))))
		      (write-string body p)))
		  ))
	      (modification-stamp o) (incf (modification-counter o)))
	(abstract-syntax o))))

(defmethod rdfxml :around ((o owl-ontology))
    (or (and  (not (something-i-depend-on-changed o)) (call-next-method))
      (setf (rdfxml o) 
	    (abstract-to-rdfxml (abstract-syntax o)))))

(defvar *default-rdfxml-writing-location* "~/Desktop/")

(defmethod write-rdfxml ((o owl-ontology) &optional path )
  (unless path (setq path (format nil "~a~a.owl" *default-rdfxml-writing-location* (string-downcase (name o)))))
  (if (about o)
      (with-output-to-string (s)
	(princ (rdfxml o) s)
	(let ((string (get-output-stream-string s)))
	  (setq string (#"replaceFirst" string "owl:Ontology rdf:about=\".*?\"" (format nil "owl:Ontology rdf:about=\"~a\"" (about o))))
	  (setq string (#"replaceFirst" string "xml:base=\".*?\"" (format nil "xml:base=\"~a\"" (base o))))
	  (with-open-file (f path :if-does-not-exist  :create :if-exists :supersede 
			     :direction :output)
	    (write-string string f))))
      (with-open-file (f path :if-does-not-exist  :create :if-exists :supersede 
		     :direction :output)
	(princ (rdfxml o) f)
	nil)))

(defmethod write-abstract ((o owl-ontology) &optional path )
  (unless path (setq path (format nil "~a~a.absowl" *default-rdfxml-writing-location* (string-downcase (name o)))))
  (with-open-file (f path :if-does-not-exist  :create :if-exists :supersede 
		     :direction :output)
    (princ (abstract-syntax o) f)
    nil))

(defmethod kb :around ((o owl-ontology))
  (or (call-next-method)
      (let ((kb (if (eq (load-using o) :owlapi)
		    (load-kb-owlapi-from-string (rdfxml o))
		    (load-kb-jena-from-string (rdfxml o)))))
	(and (rules o)
	     ;(let ((*rule-ontology* (#"getOntology" (kb-owlapi-reasoner (kb o)))))
	     (#"setRules" (kb-kb kb) (list-to-hashset (mapcar 'eval (rules o))))
	     (#"pruneSWRLIntroducedInds" (kb-kb kb)));)
	(setf (kb o) kb)
	(setf (kb-loaded-from kb) o)
	kb)))

(defmethod check ((o owl-ontology) &optional verbose)
  (multiple-value-bind (is reason)
      (consistent  o)
    (when (and verbose (not is))
      (print (second reason)))
    (unless is (return-from check nil))
    (when (not (satisfiable o))
      (when verbose (format t "Unsatisfiable: ~{~a~^, ~}~%" (unsatisfiable-classes o)))
      (return nil))
    (values t
	    (get-owl-species (kb o))
	    )))

(defun check-nolockup-kb (var path timeout repeat &optional verbose classify)
  (loop for count below repeat
       do
       (sleep .1)
       (set var (load-kb-jena path))
       (ignore-errors 
	 
	   (return-from check-nolockup-kb (with-pellet-timeout ((symbol-value var) timeout)
					    (time (check (symbol-value var)  verbose))
					    (time (#"classify" (kb-kb (symbol-value var)))))))
       do (format t "Trying to reload and check ~s, try #~a (failed to check consistency~a in ~a seconds)~%"
		  path
		  (+ count 1)
		  (if classify " and classify" "")
		  timeout))
  (error "failed to check ~a in ~a tries with timeout ~a second~%" path repeat timeout ))

(defun classify-nolockup-kb (var path consistency-timeout classify-timeout repeat)
  (block consistency 
    (loop for count below repeat
       do
       (sleep .1)
       (set var (load-kb-jena path))
       (ignore-errors 
	 (return-from consistency
	   (with-pellet-timeout ((symbol-value var) consistency-timeout)
	     (time (check (symbol-value var)  t)))))
       do (format t "Trying to reload and check ~s, try #~a (failed to check consistency in ~a seconds)~%"
		  path (+ count 1) consistency-timeout))
    (error "failed to check ~a in ~a tries with timeout ~a second~%" path repeat consistency-timeout ))
  (format t "Now trying to classify with a timeout of ~a seconds~%"  classify-timeout)  
  (with-pellet-timeout ((symbol-value var) classify-timeout)
    (time (#"classify" (kb-kb (symbol-value var))))))
    

(defmethod classify-realize ((o owl-ontology))
  (#"classify" (kb-kb (kb o)))
  (#"realize" (kb-kb (kb o))))

(defmethod classify ((o owl-ontology))
  (#"classify" (kb-kb (kb o)))
  )

(defmethod check ((kb kb) &optional verbose)
  (multiple-value-bind (is reason)
      (check-abox-consistency  kb)
    (when (and verbose (not is))
      (print (second reason)))
    (unless is (return-from check nil))
    (when (not (null (remove !owl:Nothing (kb-unsatisfiable-classes kb))))
      (when verbose (format t "Unsatisfiable(~a): ~{~a~^, ~}~%" (get-owl-species kb) (remove !owl:Nothing (kb-unsatisfiable-classes kb))))
      (return-from check nil))
    (values t
	    (get-owl-species kb))))

(defmethod check ((l list) &optional verbose)
  (eval 
   `(with-ontology foo ()
       ,l
    (check foo ,verbose))))

(defmethod abstract-syntax ((l list))
  (eval 
   `(with-ontology foo ()
       ,l
    (abstract-syntax foo))))

(defmethod rdfxml ((l list))
  (eval 
   `(with-ontology foo ()
       ,l
    (rdfxml foo))))

(defmethod satisfiable ((o owl-ontology))
  (null (remove !owl:Nothing (unsatisfiable-classes o))))

(defmethod consistent ((o owl-ontology))
  (check-abox-consistency (kb o)))  

(defmethod unsatisfiable-classes ((o owl-ontology))
  (kb-unsatisfiable-classes (kb o)))

(defmacro define-ontology (name (&key base ontology-properties about includes rules)  &body body)
  `(defparameter ,name
     (load-time-value
      (let ((*default-uri-base* (or ,base ,*default-uri-base* )))
	(make-instance 'owl-ontology 
		       :name ',name
		       :base (maybe-unabbreviate-namespace *default-uri-base*)
		       :about (or ,about (#"replaceFirst" (maybe-unabbreviate-namespace *default-uri-base*) "#*$" ""))
		       :sexp-source  (ontology  (or (and ,about (make-uri ,about))
						    (make-uri (#"replaceFirst" (maybe-unabbreviate-namespace *default-uri-base*) "#*$" "")))
						,ontology-properties ,@body)
		       :rules ,rules
		       :includes ',includes)))))


(defmacro with-ontology (name (&key base ontology-properties about includes rules) definitions &body body)
  `(let* ((*default-uri-base* (or ,base *default-uri-base* )))
     (let ((,name
	    (make-instance 'owl-ontology 
			   :name ',name
			   :base (maybe-unabbreviate-namespace *default-uri-base*)
			   :about (or ,about (maybe-unabbreviate-namespace *default-uri-base*))
			   :rules ,rules
			   :sexp-source (ontology (make-uri-base-relative "" *default-uri-base*)  ,ontology-properties ,@definitions) :includes ',includes)))
       (let ((*default-kb* ,name))
	 ,@body))))

(defun autoannotate (&rest plist)
  (cons 
   (annotation !annotationsCreatedBy "http://www.co-ode.org/downloads/autoannotator/")
   (loop for (prop value) on plist by 'cddr
      collect (annotation prop value))))

;; (defun value-partition (spec)  
;;   (setq spec (eval-uri-reader-macro spec))
;;   (let ((parent (car spec))
;; 	(children (rest spec)))
;;     (list* (if (> (length children) 1)
;; 	       (class parent :complete (apply 'union-of (mapcar (lambda(el) (if (listp el) (car el) el)) children))))
;; 	   (if (> (length children) 1)
;; 	       (apply 'disjoint-classes (mapcar (lambda(el) (if (listp el) (car el) el)) children)))
;; 	   (loop for child in children
;; 	      when (listp child)
;; 		append (value-partition child)
;; 	      collect
;; 		(class (if (listp child) (car child) child) :partial parent)))))


#|

(define-ontology inconsistent-finite-infinite ()
  (class !human)
  (class !woman)
  (class !man)
  (sub-class-of !man !human)
  (sub-class-of !woman !human)
  (disjoint-classes !woman !man)
  (object-property !child)
  (object-property !father (inverse-of !child))
  (sub-class-of !human (restriction !father (all-values-from !man)))
  (sub-class-of !human (restriction !father (cardinality 1)))
  (sub-class-of !human (restriction !child (max-cardinality 1)))
  (object-property !ssn :inverse-functional (range (one-of !one !two)))
  (sub-class-of !human (restriction !ssn (cardinality 1)))
  (individual !mary (type !woman))
  (individual !one)
  (individual !two)
  )

(define-ontology biopax-level2 (:base "bp2:")
  (class !entity))
|#

(defun label (string)
  (if (consp string)
      (annotation !rdfs:label (literal (safe-annotation-string (second string) !rdfs:label) (third string)))
      (annotation !rdfs:label (literal (safe-annotation-string string !rdfs:label) !xsd:string))))

(defun comment (string)
  (annotation !rdfs:comment (literal (safe-annotation-string string !rdfs:comment) !xsd:string)))

(defun see-also (what)
  (annotation !rdfs:seeAlso what ))

(defun owl-imports (uri)
  (ontology-annotation 
   !owl:imports 
   (if (stringp uri)
       (make-uri (maybe-unabbreviate-namespace uri))
       uri)))