;;; Quick demo:
;;;   (show-classtree "http://www.biopax.org/release/biopax-level2.owl")

;; http://prefuse.org/doc/faq/ has pointers to other frameworks

;; about edge labels.
;; http://sourceforge.net/forum/forum.php?thread_id=1704619&forum_id=343013
;; http://sourceforge.net/forum/forum.php?thread_id=1674303&forum_id=343013

;; about keycontrol
;; http://sourceforge.net/forum/forum.php?thread_id=1662654&forum_id=343013

;(add-to-classpath "~/Incoming/prefuse-beta/build/prefuse.jar")
;(add-to-classpath "~/Incoming/prefuse-beta/build/demos.jar")

;; (setq demo (#"demo" 'prefuse.demos.RadialGraphView "/Users/ruttenbe/Desktop/alzforum-database-graphml.xml" "name"))

;; (setq jframe (new 'JFrame "p r e f u s e  |  t r e e v i e w"))
;; (if scroll
;;     (progn
;;       (setq sp (new 'JScrollPane demo))
;;       (#"setContentPane" jframe sp))
;;     (#"setContentPane" jframe demo))
;; (#"pack" jframe)
;; (#"setVisible" jframe t)

;;(#"main" 'prefuse.demos.RadialGraphView (jnew-array (jclass "java.lang.String") 0 ))
;; but watch out - closing window kills application

(in-package :cl-user)

(defvar *want-hrule* t)

(defclass kb-classtree ()
  ((kb :initarg :kb :initform nil :accessor kb)
   (equivalents-seen :initarg :equivalents-seen :initform nil :accessor equivalents-seen)
   (entity2nodename :initarg :entity2nodename :initform nil :accessor entity2nodename)
   (entity2comment :initarg :entity2comment :initform nil :accessor entity2comment)
   (entity2label :initarg :entity2label :initform nil :accessor entity2label)
   ))


(defvar *current-labels* nil) ; barf
(defvar *treeview-depth* 3)

(defvar *uri-name-is-uri-hack* nil)
(defvar *inhibit-property-info-in-toolips* nil)
(defvar *toolip-font-size* 11)
(defvar *flush-annotation-value-regexp* "")
(defvar *classtree-preferred-language* nil)
(defvar *uri-name-html* t)
(defvar *annotation-query-reasoner* :none) ; flip to :jena 
(defvar *super-label* "super")
(defvar *show-logical-in-tooltip* t)

(defun uri-name-for-node (uri)
  (if (stringp uri) (setq uri (make-uri uri)))
  (if *uri-name-is-uri-hack*
      uri
      (if (or (search *blankprefix* (uri-full uri))
	      (search "bNode" (uri-full uri)))
	  (format nil "Blank~a" (#"replaceAll" (uri-full uri) "^.*[/#:](?=.)" ""))
	  (progn 
	    (when (and *current-labels* (gethash uri *current-labels*))
	      (return-from uri-name-for-node
		(if *uri-name-html*
		    (#"replaceAll" (gethash uri *current-labels*) " " #|"⋅"|# "·" )
		    (gethash uri *current-labels*)
		    )))
	    (let ((string (maybe-abbreviate-namespace  (uri-full uri))))
	      (#"replaceAll" string "^.*[/#:](?=.)" "")))
	  )
      ))

(defvar *built-in-labels* nil)

(defun built-in-labels ()
  (or *built-in-labels* 
      (progn
	(setq *built-in-labels* (make-hash-table))
	(setf (gethash !owl:AnnotationProperty *built-in-labels*) "Annotation Property")
	(setf (gethash !owl:DatatypeProperty *built-in-labels*) "Datatype Property")
	(setf (gethash !owl:ObjectProperty *built-in-labels*) "Object Property")
	*built-in-labels*)))

(defun uri-name-for-node-with-equivalents (uri kb labels &optional do)
  (or (gethash uri (built-in-labels))
      (if (or (search *blankprefix* (uri-full uri))
	      (search "bNode" (uri-full uri)))
	  (or (and labels (gethash uri labels))
	      (format nil "Blank~a" (#"replaceAll" (uri-full uri) "^.*[/#:](?=.)" "")))
	  (let ((equivalents (equivalents uri kb)))
	    (if (and do (> (length equivalents) 1))
		(values 
		 (format nil "[~{~a~^, ~}]" 
			 (loop for uri in equivalents collect 
			      (or (and labels (gethash uri labels))
				  (let ((string (maybe-abbreviate-namespace  (uri-full uri))))
				    (#"replaceAll" string "^.*[/#:](?=.)" "") ))))
		 equivalents)
		(or (and labels (gethash uri labels))
		    (let ((string (maybe-abbreviate-namespace  (uri-full uri))))
		      (#"replaceAll" string "^.*[/#:](?=.)" "")
		      (#"replaceAll" string "^.*[/#:](?=.)" ""))))
	    )
	  )))


(defvar *temp-directory* (pathname-directory (make-temp-file)))

(defun temp-directory-path (fname)
  (namestring (merge-pathnames fname (make-pathname :directory *temp-directory*))))

(defmethod write-classtree-graphml ((o owl-ontology))
  (with-open-file (f (temp-directory-path (format nil "~a-graphml.xml" (string-downcase (name o))))
			  :direction :output 
			  :if-exists :supersede
			  :if-does-not-exist :create)
    (write-string  *graphml-header* f)
    (let ((kb (kb o)))
      (let ((classes (descendants !owl:Thing kb))
	    (class-to-id (make-hash-table))
	    (idcount 0))
	(loop for class in (cons !owl:Thing classes )
	     do (setf (gethash class class-to-id) (incf idcount)))
	(loop for class in (cons !owl:Thing classes )
	     do
	     (format f "<node id=\"~a\"><data key=\"name\">~a</data></node>~%"
		     (gethash class class-to-id)
		     (uri-name-for-node class)))
	(loop for class in (cons !owl:Thing classes )
	     do
	     (loop for subclass in (children class kb)
		  do
		  (format f "<edge source=\"~a\" target=\"~a\"></edge>~%"
			  (gethash class class-to-id)
			  (gethash subclass class-to-id))))
	(format f "</graph></graphml>~%")))))

;; (defmethod write-instance-graphml ((o owl-ontology) individual)
;;   "Graph of an instance and anything it connects to (transitive closure)"
;;   (with-open-file (f (format nil "/tmp/~a-graphml.xml" (string-downcase (name o)))
;; 			  :direction :output 
;; 			  :if-exists :supersede
;; 			  :if-does-not-exist :create)
;;     (write-string  *graphml-header* f)
;;     (let ((kb (kb o)))
;;       (let ((classes (descendants !owl:Thing kb))
;; 	    (class-to-id (make-hash-table))
;; 	    (idcount 0))
;; 	(loop for class in (cons !owl:Thing classes )
;; 	     do (setf (gethash class class-to-id) (incf idcount)))
;; 	(loop for class in (cons !owl:Thing classes )
;; 	     do
;; 	     (format f "<node id=\"~a\"><data key=\"name\">~a</data></node>~%"q
;; 		     (gethash class class-to-id)
;; 		     (uri-name-for-node class)))
;; 	(loop for class in (cons !owl:Thing classes )
;; 	     do
;; 	     (loop for subclass in (children class kb)
;; 		  do
;; 		  (format f "<edge source=\"~a\" target=\"~a\"></edge>~%"
;; 			  (gethash class class-to-id)
;; 			  (gethash subclass class-to-id))))
;; 	(format f "</graph></graphml>~%")))))

(defmethod write-classtree-treeml ((o owl-ontology) &key root
				   (fname (temp-directory-path (format nil "~a-treeml.xml" (string-downcase (name o)))))
				   include-instances include-tooltips merge-same dont-show (use-labels t) max-tree-size)
  (write-classtree-treeml (kb o) :root root :fname fname :include-instances include-instances :merge-same merge-same :dont-show dont-show :use-labels use-labels :max-tree-size max-tree-size :include-tooltips include-tooltips))

(defmethod write-classtree-treeml ((kb kb) &key root (fname (temp-directory-path "kb-treeml.xml")) 
				   include-instances merge-same dont-show sort-function (use-labels t) max-tree-size
				   include-tooltips)
  (let ((unsatisfiable (equivalents !owl:Nothing kb))
	(equivalents-seen (make-hash-table))
	(labels (and use-labels (rdfs-labels kb))))
    (macrolet ((satisfiable-children (node kb)
		 `(set-difference (children ,node ,kb) unsatisfiable :test 'eq)))
      (with-open-file (f fname :direction :output :if-exists :supersede :if-does-not-exist :create)
	(write-string  "<tree> <declarations><attributeDecl name=\"name\" type=\"String\"/> <attributeDecl name=\"entity\" type=\"String\"/><attributeDecl name=\"tooltip\" type=\"String\"/></declarations>" f)
	(labels ((subtree (node)
		   (unless (or (gethash node equivalents-seen)
			       (member node dont-show))
		     (let ((children (satisfiable-children node kb)))
		       (when sort-function 
			 (setq children (funcall sort-function children)))
		       (when (and (equal node !owl:Thing) unsatisfiable)
			 (setq children (append children (list !owl:Nothing))))
		       (cond ((and (null children)  (or (not include-instances) (not (instances node kb))))
			      (format f "<leaf><attribute name=\"name\" value=\"~a\"/><attribute name=\"entity\" value=\"~a\"/>~a</leaf>~%" 
				      (multiple-value-bind (name equivs)
					  (uri-name-for-node-with-equivalents node kb labels merge-same)
					(loop for equiv in equivs do (setf (gethash equiv equivalents-seen) t))
					name)
				      (uri-full node)
				      (if include-tooltips
					  (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						  (encode-tooltip-for-xml-attribute (tree-tooltip kb node)))
					  "")
				      ))
			     ((and (null children) include-instances (instances node kb))
			      (format f "<branch><attribute name=\"name\" value=\"~a\"/><attribute name=\"entity\" value=\"~a\"/>~a~%" 
				      (multiple-value-bind (name equivs)
					  (uri-name-for-node-with-equivalents node kb labels merge-same)
					(loop for equiv in equivs do (setf (gethash equiv equivalents-seen) t))
					name)
				      (uri-full node)
				      (if include-tooltips
					  (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						  (encode-tooltip-for-xml-attribute (tree-tooltip kb node)))
					  ""))
			      (loop for i in (direct-instances node kb)
				 for count from 0
				 unless (and max-tree-size (> count max-tree-size))
				 do
				   (format f "<leaf><attribute name=\"name\" value=\"~a(i)\"/><attribute name=\"entity\" value=\"~a\"/>~a</leaf>~%" 
					 (uri-name-for-node-with-equivalents i  kb labels  merge-same )
					 (uri-full i)
					 (if include-tooltips
					  (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						  (encode-tooltip-for-xml-attribute (tree-tooltip kb i)))
					  "")))
			      (format f "</branch>~%"))
			     (t
			      (format f "<branch><attribute name=\"name\" value=\"~a\"/><attribute name=\"entity\" value=\"~a\"/>~a~%"
				      (format nil "~a (~a)" (multiple-value-bind (name equivs)
							       (uri-name-for-node-with-equivalents node kb labels merge-same)
							     (loop for equiv in equivs do (setf (gethash equiv equivalents-seen) t))
							     name)
					      (length (satisfiable-children node kb)))
				      (uri-full node)
				      (if include-tooltips
					  (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						  (encode-tooltip-for-xml-attribute (tree-tooltip kb node)))
					  ""))
			      (loop for child in children
				 for count from 0
				 unless (and max-tree-size (> count max-tree-size))
				 do (subtree child))
			      (when include-instances
				(loop for i in (direct-instances node kb)
				   for count from 0
				   unless (and max-tree-size (> count max-tree-size))
				 do
				 (format f "<leaf><attribute name=\"name\" value=\"~a(i)\"/><attribute name=\"entity\" value=\"~a\"/>~a</leaf>~%" 
					 (uri-name-for-node-with-equivalents i  kb labels  merge-same ) (uri-full i)
					 (if include-tooltips
					  (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						  (encode-tooltip-for-xml-attribute (tree-tooltip kb i)))
					  ""))))
			      (format f "</branch>~%")))))))
	  (subtree (or root !owl:Thing)))
	(write-string  "</tree> " f)
	fname))))

(defmethod write-propertytree-treeml ((kb kb) &key root (fname (temp-directory-path "kb-treeml.xml")) include-instances merge-same (include-annotation-properties t) (use-labels t) dont-show (include-tooltips nil))
  (let ((unsatisfiable (equivalents !owl:Nothing kb))
	(equivalents-seen (make-hash-table))
	(role-taxonomy (#"getTaxonomy" (#"getRBox" (kb-kb kb))))
	(labels (and use-labels (rdfs-labels kb))))
    (macrolet ((satisfiable-children (node kb)
		 `(set-difference (children ,node ,kb) unsatisfiable :test 'eq)))
      (with-open-file (f fname :direction :output :if-exists :supersede :if-does-not-exist :create)
	(write-string  "<tree> <declarations><attributeDecl name=\"name\" type=\"String\"/> <attributeDecl name=\"entity\" type=\"String\"/><attributeDecl name=\"tooltip\" type=\"String\"/></declarations>" f)
	(labels ((subtree (jnode kind)
		   (setq *jnode* jnode)
		   (let ((node  (car (remove-if 'consp (remove !owl:Nothing (mapcar (lambda(c)
											 (if (stringp c) c (aterm-to-sexp c)))
										       (set-to-list (#"getEquivalents" jnode)))
								  :test 'equalp)))))
;		     (unless (stringp node) 
;		       (setq node (aterm-to-sexp node)))
;		     (if (consp node) (setq node (second node)))
		     (when (equal node !owl:Thing) 
		       (setq node !rdf:Property))
		     (setq node (make-uri  node))
		     (cond ((eq node !rdf:Property)
			    (setq node
				  (ecase kind
				    (:object-property !owl:ObjectProperty)
				    (:annotation-property !owl:AnnotationProperty)
				    (:datatype-property !owl:DatatypeProperty))))
			   ((not (eq (property-type  node kb) kind))
			    (return-from subtree)))
		       
		     (unless (or (gethash node equivalents-seen) (member node dont-show))
		       (let* ((jchildren (#"getSubs" jnode))
;			      (children (mapcar (lambda(el)(if (consp el) (second el) el)) (remove !owl:Nothing (mapcar (lambda(c)
;									  (if (stringp c) c (aterm-to-sexp c)))
;									(mapcar #"getName" (set-to-list jchildren)))
;						:test 'equalp)))
			      (children (remove-if 'consp (remove !owl:Nothing (mapcar (lambda(c)
											 (if (stringp c) c (aterm-to-sexp c)))
										       (mapcan 'set-to-list (mapcar #"getEquivalents" (set-to-list jchildren))))
								  :test 'equalp)))
			      (child-count 
			       (if (eq kind :annotation-property)
				   (let ((count 0))
				     (maphash (lambda(name type-entity)
					     (destructuring-bind (type . entity) type-entity
					       (when (eq type :annotation-property) (incf count))))
					   (kb-name2entity kb))
				     count)
				  (count-if (lambda(p) (eq (property-type p kb) kind)) children))))
			 (cond ((null children)
				(format f "<leaf><attribute name=\"name\" value=\"~a\"/><attribute name=\"entity\" value=\"~a\"/>~a</leaf>~%" 
					(multiple-value-bind (name equivs)
					    (uri-name-for-node-with-equivalents node kb labels nil)
					;(loop for equiv in equivs do (setf (gethash equiv equivalents-seen) t))
					  name)
					(uri-full node)
					(if include-tooltips
					    (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						    (encode-tooltip-for-xml-attribute (tree-tooltip kb node)))
					    "")
					))
			       (t
				(format f "<branch><attribute name=\"name\" value=\"~a\"/><attribute name=\"entity\" value=\"~a\"/>~a~%"
					(format nil "~a (~a)" (multiple-value-bind (name equivs)
								 (uri-name-for-node-with-equivalents node kb labels nil)
					;(loop for equiv in equivs do (setf (gethash equiv equivalents-seen) t))
							       name)
						child-count)
					(uri-full node)
					(if include-tooltips
					    (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
						    (encode-tooltip-for-xml-attribute (tree-tooltip kb node)))
					    ""))
				(loop for jchild in (set-to-list jchildren)
				   do (subtree jchild kind))
				(when (and (equal node !owl:AnnotationProperty) include-annotation-properties) 
				  (maphash (lambda(name type-entity)
					     (destructuring-bind (type . entity) type-entity
					       (when (eq type :annotation-property)
						 (format f "<leaf><attribute name=\"name\" value=\"~a\"/><attribute name=\"entity\" value=\"~a\"/>~a</leaf>~%" 
							 (uri-name-for-node-with-equivalents (make-uri name)  kb labels nil)
							 (uri-full (make-uri name))
							 (if include-tooltips
							     (format nil "<attribute name=\"tooltip\" value=\"~a\"/>"
								     (encode-tooltip-for-xml-attribute (tree-tooltip kb node)))
							     "")))))
					   (kb-name2entity kb))
				  )
				(format f "</branch>~%")))))
		     
		       )))

	  (format f "<branch><attribute name=\"name\" value=\"Property(3)\"/><attribute name=\"entity\" value=\"~a\"/>~%" (uri-full !rdf:Property))
	  (subtree (#"getTop" role-taxonomy) :annotation-property)
	  (subtree (#"getTop" role-taxonomy) :datatype-property)
	  (subtree (#"getTop" role-taxonomy) :object-property)
	  (format f "</branch>~%")
	  (write-string  "</tree> " f)
	  fname))
      )))

(defparameter *graphml-header*
  "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<graphml xmlns=\"http://graphml.graphdrawing.org/xmlns\">
<graph edgedefault=\"directed\">
 
<!-- data schema -->
<key id=\"name\" for=\"node\" attr.name=\"name\" attr.type=\"string\"/>")

(defvar @@ nil)

(defun make-treeview (file name kb &optional (depth *treeview-depth*))
  (maybe-hook-@@)
  (#"setDismissDelay" (#"sharedInstance" 'tooltipmanager) 300000) ;; make the tooltips last longer
  (#"setInitialDelay" (#"sharedInstance" 'tooltipmanager) 10)
  (let ((jpanel (#"demo" 'prefuse.demos.TreeView file "name"))
	(jframe (new 'JFrame (string-capitalize name))))
    (setq panel jpanel)
    (let ((visualization (#"getVisualization" (#"getComponent" jpanel 0) )))
      (setq vis visualization)
      (#"addControlListener" (#"getComponent" jpanel 0) (make-tooltip-control kb 'tree-tooltip))
      (#"setDistance" (#"get" (#"getAction" visualization "filter") 0) depth) ;; 3 deep versus 2
      (#"setDefaultFont" (#"get" (#"getAction" visualization "filter") 1) (#"getFont" 'FontLib "Tahoma" 12 12) ) ;smaller font
      (#"run" visualization "filter")
      (#"run" visualization "treeLayout")
					;(print (#"get" (#"getItem" (#"getVisualGroup" it "tree.nodes") 1) "name"))
					; (#"getDOI" (#"getItem" (#"getVisualGroup" it "tree.nodes") 1))`
      ;;       (let ((bounds (#"getBounds" visualization (get-java-field 'Visualization "ALL_ITEMS"))))
      ;; 	(#"expand" 'GraphicsLib bounds (#"getScale" (#"getComponent" jpanel 0)))
      ;; 	(#"fitViewToBounds" 'DisplayLib (#"getComponent" jpanel 0) bounds (make-immediate-object 0 :long)))
      (#"setContentPane" jframe jpanel)
      (#"pack" jframe)
      (#"setVisible" jframe t)
      #+darwin (run-shell-command "osascript -e 'tell application \"java\"' -e \"activate\" -e \"end tell\"")
      ))
  kb)

(defmethod show-classtree ((url string) &rest stuff)
  (apply 'show-classtree (load-kb-jena url) stuff))

(defmethod show-classtree ((symbol symbol) &rest stuff)
  (apply 'show-classtree (load-kb-jena symbol) (append (standard-ontology-classtree-options symbol) stuff )))

(defmethod show-classtree ((o owl-ontology) &rest stuff) ;&key root include-instances merge-same dont-show (use-labels t))
  (make-treeview (apply 'write-classtree-treeml (kb o)  stuff) (string (name o)) (kb o)
		 (or (getf stuff :depth) *treeview-depth*)))

;:root root :dont-show dont-show :include-instances include-instances :merge-same merge-same :use-labels use-labels) (string (name o)) (kb o)))

(defmethod show-classtree ((kb kb) &rest stuff)
  (make-treeview (apply 'write-classtree-treeml kb stuff) (string(kb-loaded-from kb)) kb (or (getf stuff :depth) *treeview-depth*)))

(defmethod show-propertytree ((symbol symbol) &rest stuff)
  (apply 'show-propertytree (load-kb-jena symbol) stuff))

(defmethod show-propertytree ((url string) &key root include-instances merge-same (include-annotation-properties t) (use-labels t) (dont-show t))
  (show-propertytree (load-kb-jena url) :root root :include-instances include-instances :merge-same merge-same
		     :include-annotation-properties include-annotation-properties))

(defmethod show-propertytree ((o owl-ontology) &key root include-instances merge-same (include-annotation-properties t) (use-labels t) (dont-show nil))
  (make-treeview (write-propertytree-treeml (kb o) :root root :include-instances include-instances :merge-same merge-same
					    :include-annotation-properties include-annotation-properties)
		 (string (name o)) (kb o)))

(defmethod show-propertytree ((kb kb) &key root include-instances merge-same (include-annotation-properties t) (use-labels t) (dont-show nil))
  (make-treeview (write-propertytree-treeml kb :root root :include-instances include-instances :merge-same merge-same
					    :include-annotation-properties include-annotation-properties :dont-show dont-show) 
		 (string(kb-loaded-from kb)) kb))


;; http://sourceforge.net/forum/message.php?msg_id=3339297
;; RE: directed layered (hierarchical) layout 
;; 2005-09-14 15:10
;; There's no existing layout that will do this exactly. Some options include hacking VerticalTreeLayout to create a new layout that does what you want, or playing with the ForceDirectedLayout and adding a downstream Action instance that forces nodes to stay within horizontal "bands" depending on the depth level of the node. 
 
;; Hope that helps, 
;; -jeff 


(defun make-tooltip-control (kb tooltip-function &optional
			     (tooltip-ok? (lambda(item) (#"canGetString" item "entity")))
			     (tooltip-arg (lambda(item) (#"getString" item "entity"))))
  (let ((fields (jnew-array "java.lang.String" 1)))
    (jarray-set fields "tooltip"  0)
    (let ((wrapped (new 'tooltipcontrol fields))
	  (interfaces (jclass-all-interfaces 'tooltipcontrol)))
      (jdelegating-interface-implementation  
       (car interfaces)
       wrapped
       "itemEntered" 
       (let ((kb kb))
	 (lambda (item event &aux display)
	   (unless (#"isShiftDown" event)
	     (handler-case 
		 (multiple-value-bind (value errorp)
		     (ignore-errors 
		       (setq display (#"getSource" event))
		       (when  (funcall tooltip-ok? item)
			 (funcall tooltip-function kb (funcall tooltip-arg item))))
		   (and display
			(if (and value (not errorp))
			    (#"setToolTipText" display value)
			    (if errorp
				(#"setToolTipText" display (format nil "Error creating tooltip for ~a" (#"getSourceTuple" item)))))))
	       (condition () nil)
	       ))))
       "itemExited"
       (lambda (item event &aux display)
	 (handler-case 
	     (multiple-value-bind (value errorp)
		 (ignore-errors 
		   (setq display (#"getSource" event)))
	       (and display
		    (if (not errorp)
			(unless (#"isShiftDown" event)
			  (#"setToolTipText" display (make-immediate-object nil :ref)))
			)))
	   (condition () nil)
	   ))
       ))))

(defun rdfs-comment (entity kb)
  (let ((uri (make-uri entity)))
    (format nil "~{~a~^; ~}" 
	    (or
	     (or 
	      (and *classtree-preferred-language*
		   (sparql `(:select (?comment) () (,uri !oboinowl:hasDefinition ?def) (?def !rdfs:label ?comment) (:filter (and (equal (lang ?comment) ,*classtree-preferred-language*) (not (equal ?comment ""))))) :use-reasoner *annotation-query-reasoner* :kb kb :flatten t))
	      (sparql `(:select (?comment) () (,uri !oboinowl:hasDefinition ?def) (?def !rdfs:label ?comment) (:filter (not (equal ?comment "")))) :use-reasoner *annotation-query-reasoner* :kb kb :flatten t)
	      )
	     (or
	      (and *classtree-preferred-language*
		   (sparql `(:select (?comment) () (,uri !rdfs:comment ?comment) (:filter (and (equal (lang ?comment) ,*classtree-preferred-language*)
											       (not (equal ?comment "")))))
			   :kb kb :use-reasoner *annotation-query-reasoner* :flatten t))
	      (sparql `(:select (?comment) () (,uri !rdfs:comment ?comment) (:filter (not (equal ?comment "")))) :kb kb :use-reasoner *annotation-query-reasoner* :flatten t))
	     (or 
	      (and *classtree-preferred-language*
		   (sparql `(:select (?comment) () (:union ((,uri !obi:OBI_0000291 ?comment))
							   ((,uri !obi:IAO_0000115 ?comment)))
				     (:filter (and (equal (lang ?comment) ,*classtree-preferred-language*)
												  (not (equal ?comment "")))))
			   :kb kb :use-reasoner *annotation-query-reasoner* :flatten t))
	      (sparql `(:select (?comment) () (:union ((,uri !obi:OBI_0000291 ?comment))
							   ((,uri !obi:IAO_0000115 ?comment))) (:filter (not (equal ?comment "")))) :kb kb :use-reasoner *annotation-query-reasoner* :flatten t))
	     ))))


;; (defun rdfs-comment (entity kb)
;;   (let ((uri (make-uri entity)))
;;     (or
;;      (caar (sparql `(:select (?comment) () 
;; 			     (:union 
;; 			      ((,uri !rdfs:comment ?comment))
;; 			      ((,uri !oboinowl:hasDefinition ?def) (?def !rdfs:label ?comment))))
;; 		   :use-reasoner :jena :kb kb)))))

(defun clean-label (label &optional (ignore-if-xml nil))
  (let ((cleaned 
	 (and label
	      (#"replaceAll" 
	       (#"replaceAll"
		(#"replaceAll" (#"replaceFirst" (#0"replaceFirst" label "^\\s+" "") "\\s+$" "")  "<" "&lt;")
		">" "&gt;") "\"" "&quot;"))))
    (when cleaned
      (if (and (> (length cleaned) 35) (char= (char cleaned 0) #\&))
	  (if ignore-if-xml
	      nil
	      cleaned)
	  (if (equal cleaned "") nil cleaned)
	  ))))

(defun rdfs-label (entity kb)
  (let ((uri (make-uri entity)))
    (remove nil
	    (mapcar 'clean-label
		    (append
		     (or
		      (and *classtree-preferred-language*
			   (mapcar 'car (sparql `(:select (?label) (:distinct t) (,uri !rdfs:label ?label)
							  (:filter (equal (lang ?label) ,*classtree-preferred-language*))) :kb kb :use-reasoner *annotation-query-reasoner*)))
		      (mapcar 'car (sparql `(:select (?label) (:distinct t) (,uri !rdfs:label ?label)) :kb kb :use-reasoner *annotation-query-reasoner*)))
		     (or
		      (and *classtree-preferred-language*		     
			   (mapcar 'car (sparql `(:select (?label) (:distinct t) (,uri !foaf:name ?label) (:filter (equal (lang ?label) ,*classtree-preferred-language*))) :kb kb :use-reasoner *annotation-query-reasoner*)))
		      (mapcar 'car (sparql `(:select (?label) (:distinct t) (,uri !foaf:name ?label)) :kb kb :use-reasoner *annotation-query-reasoner*)))
		     (or
		      (and *classtree-preferred-language*		     
			   (mapcar 'car (sparql `(:select (?comment) (:distinct t) (,uri !swan:title ?comment)(:filter (equal (lang ?comment) ,*classtree-preferred-language*))) :use-reasoner *annotation-query-reasoner* :kb kb)))
		      (mapcar 'car (sparql `(:select (?comment) (:distinct t) (,uri !swan:title ?comment)) :use-reasoner *annotation-query-reasoner* :kb kb))))))))


(defun rdfs-labels (kb)
  (or (kb-uri2label kb)
      (setf (kb-uri2label kb)
	    (loop with table = (make-hash-table)
	       for (uri label) in 
	       (or
		(or
		 (and *classtree-preferred-language*
		       (sparql `(:select (?uri ?label) () (?uri !rdfs:label ?label)
						     (:filter (equal (lang ?label) ,*classtree-preferred-language*))) :kb kb :use-reasoner *annotation-query-reasoner*))
		  (sparql `(:select (?uri ?label) () (?uri !rdfs:label ?label)) :kb kb :use-reasoner *annotation-query-reasoner*))
		(or
		 (and *classtree-preferred-language*		     
		       (sparql `(:select (?uri ?label) () (?uri !foaf:name ?label) (:filter (equal (lang ?label) ,*classtree-preferred-language*))) :kb kb :use-reasoner *annotation-query-reasoner*))
		  (sparql `(:select (?uri ?label) () (?uri !foaf:name ?label)) :kb kb :use-reasoner *annotation-query-reasoner*))
		(or
		 (and *classtree-preferred-language*		     
		  (sparql `(:select (?uri ?comment) () (?uri !swan:title ?comment)(:filter (equal (lang ?comment) ,*classtree-preferred-language*))) :use-reasoner *annotation-query-reasoner* :kb kb))
		 (sparql `(:select (?uri ?comment) () (?uri !swan:title ?comment)) :use-reasoner *annotation-query-reasoner* :kb kb)))
	       for clean-label = (clean-label label t)
	       when clean-label do (setf (gethash uri table ) clean-label)
	       finally (return table)))))

(defun encode-tooltip-for-xml-attribute (tooltip)
  (xml-encode-string-with-unicode (#"replaceAll" tooltip "\\n" "<br>")))


;; BUG (:filter (not (regex ?comment "^\\s*$"))) doesn't work
(defun rdfs-comments (kb)

  (or (kb-uri2comment kb)
      (setf (kb-uri2comment kb)
	    (loop with table = (make-hash-table)
	       for (uri comment) in 
		 (append
		  (sparql `(:select (?uri ?comment) () (?uri !rdfs:comment ?comment) ) :kb kb :use-reasoner *annotation-query-reasoner*)
		  (sparql `(:select (?uri ?comment) () (:union ((?uri !obi:OBI_0000291 ?comment))
							   ((?uri !obi:IAO_0000115 ?comment))))
			  :kb kb :use-reasoner *annotation-query-reasoner*)
		  (sparql `(:select (?uri ?comment) () (?uri !oboinowl:hasDefinition ?def) (?def !rdfs:label ?comment)) :use-reasoner *annotation-query-reasoner* :kb kb)
		  )
		 do
	       (when (and comment (not (#"matches" comment "^\\s*$")))
		 (if (gethash uri table nil)
		     (setf (gethash uri table) (format nil "~a; ~a" comment (gethash uri table)))
		     (setf (gethash uri table) comment)))
	       finally (return table)))))

;; unused
(defun wrap-comment (comment &optional (prefix ""))
  (and comment
       (let ((words nil) (lines nil) (so-far 0) (max-length 80))
	 (flet ((end-line () (push (format nil "~{~a~^ ~}" (reverse words)) lines)
			  (setq words nil so-far 0)))
	   (loop for word in (map 'list #"toString" (#"split" (#"replaceAll" comment "\\\\\"" "\"") "\\s+"))
	      do
	      (cond ((> (+ so-far (length word)) max-length)
		     (end-line)
		     (push word words) (incf so-far (length word)))
		    (t (push word words) (incf so-far (length word)))))
	   (when words (end-line)))
	 (format nil (concatenate 'string "~{~a~^<br>" prefix "~}") (reverse lines)))))

(defun format-sexp-for-tooltip (form)
  (if (equal form "") 
      ""
      (#"replaceAll"
       (#"replaceAll"
	(#"replaceAll" 
	 (#"replaceAll" 
	  (let ((*print-case* :downcase)
		(*print-pretty* t)
		(*print-right-margin* 100)
		(*print-readably* nil))
	    (loop for (old pretty) in '((and "<i>and</i>") (some "<i>some</i>") (or "<i>or</i>") 
					 (all "<i>all</i>")  (has "<i>has</i>") 
					 (min "<i>min</i>") (max "<i>max</i>")
					 (exactly "<i>exactly</i>") (not "<i>not</i>"))
		do (setq form (subst pretty old form)))
	    (format nil "~w" (or form "")))
	  "\\n" "<br>")
	 " " "&nbsp;") 
	"([^\\\\]|^)\"" "$1")
       "\\\\\"" "\"")))

(defun format-parents (entity kb)
  (let* ((asserted (sparql `(:select (?parent) () (,entity !rdfs:subClassOf ?parent) (:filter (not (isblank ?parent)))) :kb kb :use-reasoner :none :flatten t))
	 (inferred (set-difference (parents entity kb) asserted))
	 (mi? (> (length asserted) 1)))
    (if (or inferred asserted)
	(format nil "~{~a~^, ~}"
		 (append
		  (mapcar (lambda(c)
			    (if mi?
				(format nil "<font color=\"red\">~a</font>" (car (rdfs-label c kb)) )
				(car (rdfs-label c kb))))
			  (remove-duplicates asserted :test 'equalp))
		  (mapcar (lambda(c) (format nil "<i>~a</i>" (car (rdfs-label c kb)) inferred))
			  (remove-duplicates inferred :test 'equalp))
		  ))
	"<i><font color=\"red\">Thing</font></i>")))

;; to make note of relevant properties for each class
;; for each property, extract and name the class foo-domain, foo-range
;; take a probe class. 
;; If it is equivalent to any of these, then say it *is* dr
;; If it is a subclass of any of these then report all of it is *part* of dr
;; If it is a superclass of any of these then report some of it is in dr
;; If it is non-disjoint sibling (or subclass) then report it might overlap dr
;; If DR is owl:thing perhaps say something different

(defun tree-tooltip (kb entity &key (width 500))
  (if (java-object-p entity)
      (setq entity (uri-full (aterm-to-sexp entity)))
      (when (uri-p entity) (setq entity (uri-full entity))))
  (let ((*default-kb* kb))
    (let ((*current-labels* (rdfs-labels kb)))
      (multiple-value-bind (aterm type) (and (has-entity? entity kb) (get-entity entity kb))
	(setq @ (make-uri entity))
	(let ((comment (let ((it (rdfs-comment entity kb)))
			 (and it  (#"replaceAll" it "<" "&lt;"))))
	      (labels (rdfs-label entity kb)))
	  (flet ((p-label (uri from-aterm)
		   (if (rdfs-label uri kb)
		       (car (rdfs-label uri kb))
		       from-aterm)))
	    (setq @@
		  (format nil "<html><div style=\"font-size:~a;width:~a\"><b>~a</b>~a<i>~a</i>~a</div></html>" *toolip-font-size* width
			  (format nil "~{~a<br>~}" 
				  (loop for e in (if (eq type :class) 
						     (or (equivalents (make-uri entity) kb) (list (make-uri entity)))
						     (if (member type '(:object-property :datatype-property))
							 (cons (make-uri entity) (same-properties (make-uri entity) kb))
							 (if (or (null type) (eq type :annotation-property))
							     (list (make-uri entity))
							     (cons (make-uri entity) (sames (make-uri entity) kb)))))
				     collect (format nil "~a~a" (if type (concatenate 'string (string-capitalize (string type)) ": ") "") (uri-full e))))
			  (if labels (format nil "~{<b><i>~a</i></b>~^<br>~}" labels) "")
			  (if (equal entity (uri-full !owl:Nothing)) 
			      "These classes are unsatisfiable!<br>"
			      (if (and comment  (not (equal comment "")))
				  (format nil "<div style=\"margin-left:5px;margin-top:2px;margin-bottom:2px\">~a</div>" comment)
				  (if labels  "<br>" ""))) ; <br>
			  (cond ((eq type :class)
				 (let ((parents (format-parents (make-uri entity) kb))
				       (form (coalesce-disjoints (pretty-aterm-sexp
								  (mapcar 
								   'aterm-to-sexp
								   (setq axioms 
									 (set-to-list 
									  (#"getAxioms" (#"getTBox" (kb-kb kb)) aterm))))))))
				   (with-output-to-string (s)
				     (format s "<b>~a:  ~a</b>"
					     *super-label*
					     parents)
				     (when *show-logical-in-tooltip*
				       (format s "<br><font color=\"#000080\">~a</font>"
					     (let ((*print-right-margin* (floor width 8)))
					       (if (consp form)
						   (concatenate 'string (format-sexp-for-tooltip form)  "<br>")
						   ""
						   ))))
				     (let* ((apv (annotation-property-values-or-labels entity kb)))
				       (loop for (p val) in apv
					  with need-hrule = t
					  when (and val (not (eq p !rdfs:comment)) (not (eq p !rdfs:label)))
					    unless (and (not (uri-p val)) (#"matches" val *flush-annotation-value-regexp*))
					  do 
					  (let ((p-label (p-label (uri-full p) (pretty-aterm-sexp (aterm-to-sexp (get-entity (uri-full p) kb))))))
					    (when (and need-hrule *want-hrule*) (format s "<hr>") (setq need-hrule nil))
					    (format s "<i>~a</i>: ~a<br>" 
						    p-label
						    (if (uri-p val)
							(or (car (rdfs-label (uri-full p) kb))
							    (pretty-aterm-sexp val))
							(if (stringp val)
							    val
							    val)))))
				       )
				     (unless (or *inhibit-property-info-in-toolips* (equal entity (uri-full !owl:Nothing)))
				       (let nil ;((*current-labels* nil))
					 (multiple-value-bind (in-domain-of in-domain-of-subclass maybe-in-domain-of) (properties-that-can-have-as-subject (make-uri entity) kb)
					   (multiple-value-bind (in-range-of in-range-of-subclass maybe-in-range-of) (properties-that-can-have-as-object (make-uri entity) kb)
					     (when (or in-domain-of in-range-of maybe-in-range-of maybe-in-domain-of in-domain-of-subclass in-range-of-subclass)
					       (when *want-hrule* (write-string "<hr>" s))
					       (when in-domain-of
						 (format s "<b>Subject of</b>: ~a<br>"  (join-with-char  (remove "ObsoleteProperty"  (mapcar 'pretty-aterm-sexp in-domain-of) :test 'equal) ", " )))
					       (when (or maybe-in-domain-of in-range-of-subclass)
						 (format s "<b>Possibly subject of</b>: ~a<br>"
							 (join-with-char (remove "ObsoleteProperty"
										 (append (mapcar (lambda(p) (format nil "<font color=\"#900000\">~a</font>" (pretty-aterm-sexp p))) maybe-in-domain-of)
											 (mapcar (lambda(p) (format nil "<font color=\"#505050\">~a</font>" (pretty-aterm-sexp p))) in-domain-of-subclass)) 
										 :test 'equal)
									 ", ")
							 ))
					       (when in-range-of
						 (format s "<b>Object of</b>: ~a<br>" (join-with-char (remove "ObsoleteProperty" (mapcar 'pretty-aterm-sexp in-range-of) :test 'equal) ", " )))
				 
					       (when (or maybe-in-range-of in-range-of-subclass)
						 (format s "<b>Possibly object of</b>: ~a<br>"
							 (join-with-char (remove "ObsoleteProperty"
										 (append (mapcar (lambda(p) (format nil "<font color=\"#900000\">~a</font>" (pretty-aterm-sexp p))) maybe-in-range-of)
											 (mapcar (lambda(p) (format nil "<font color=\"#505050\">~a</font>" (pretty-aterm-sexp p))) in-range-of-subclass)) 
										 :test 'equal)
									 ", ")
							 ))))))))))
				((eq type :individual)
				 (with-output-to-string (s)
				   (format s "a ~{~a~^, ~}<br>"
					   (or (remove "_TOP_"
						       (mapcar 'pretty-aterm-sexp
							       (mapcar 'aterm-to-sexp
								       (apply 'append
									      (map 'list 'set-to-list
										   (set-to-list (#"getTypes" (kb-kb kb) aterm t))))))
						       :test 'equal)
					       (list "Thing")))
				   (let* ((props (kb-properties kb))
					  (vs (mapcar (lambda(p) (mapcar 'aterm-to-sexp (set-to-list (#"getPropertyValues" (kb-kb kb) p aterm)))) props))
					  (apv (annotation-property-values-or-labels entity kb)))
				     (loop for p in (append props (mapcar (lambda(pv) (get-entity (uri-full(first pv)) kb)) apv))
					for vals in (append vs (mapcar 'list (mapcar 'second apv)))
					with need-hrule = t
					when vals 
					do (let ((p (pretty-aterm-sexp (aterm-to-sexp p))))
					     (unless (and (listp p) (equal (caar p) :inv))
					       (when (and need-hrule *want-hrule*) (format s "<hr>") (setq need-hrule nil))
					       (write-string 
						(format nil "<i>~a</i>: ~{~a~^, ~}<br>" 
							p
							(mapcar (lambda (v) (if (stringp v) 
										v
										(if (uri-p v)
										    (or (car (rdfs-label (uri-full v) kb))
											(pretty-aterm-sexp v))
										    (pretty-aterm-sexp v))))
								vals)
							"&nbsp;&nbsp;&nbsp;&nbsp;") s)))
					))))
				((member type '(:object-property :datatype-property))
				 (let ((subs
					(pretty-aterm-sexp 
					 (mapcar (lambda(a)
						   (if (atom a) (uri-name-for-node a) a))
						 (mapcar 'aterm-to-sexp
							 (apply 'append (mapcar 'set-to-list 
										(set-to-list
										 (#"getSubProperties" (kb-kb kb) aterm t))))))))
				       (supers
					(pretty-aterm-sexp 
					 (mapcar (lambda(a)
						   (if (atom a) (uri-name-for-node a) a))
						 (mapcar 'aterm-to-sexp
							 (apply 'append (mapcar 'set-to-list 
										(set-to-list
										 (#"getSuperProperties" (kb-kb kb) aterm t))))))))
				       (inverses
					(mapcar (lambda(a)
						  (if (atom a) (uri-name-for-node a) a))
						(mapcar 'aterm-to-sexp
							(set-to-list
							 (#"getInverses" (kb-kb kb) aterm)) )))
				       (domain (let ((raw (#"getDomain" (#"getRole" (#"getRBox" (kb-kb kb)) aterm))))
						 (pretty-aterm-sexp
						  (if (null raw) 
						      (pretty-aterm-sexp !owl:Thing)
						      (aterm-to-sexp (#"nnf" 'AtermUtils raw))))))
				       (range (let ((raw (#"getRange" (#"getRole" (#"getRBox" (kb-kb kb)) aterm))))
						(pretty-aterm-sexp 
						 (if (null raw) 
						     (if (eq type :object-property) !owl:Thing !rdf:Literal)
						     (aterm-to-sexp (#"nnf" 'AtermUtils raw))))))
				       )
				   (with-output-to-string (s)
			   
				     (write-string (property-attributes type aterm kb) s)
				     (when inverses
				       (format s "<b>Inverse of</b>: ~{~a~^, ~}<br>" inverses))
				     (when supers
				       (format s "<b>Subproperty of</b>: ~{~a~^, ~}<br>" (if (not (listp supers)) (list supers) supers)))
				     (when subs
				       (format s "<b>Subproperties</b>: ~{~a~^, ~}<br>" (if (not (listp subs)) (list subs) subs)))
				     (format s "<b>Domain</b>: ~a<br>" (format-sexp-for-tooltip domain))
				     (format s "<b>Range</b>: ~a<br>" (format-sexp-for-tooltip range))
				     (let* ((apv (annotation-property-values-or-labels entity kb)))
				       (loop for (p val) in apv
					  with need-hrule = t
					  when (and val (not (eq p !rdfs:comment)) (not (eq p !rdfs:label)))
					  do 
					  (let ((p-label (p-label (uri-full p) (pretty-aterm-sexp (aterm-to-sexp (get-entity (uri-full p) kb))))))
					    (when (and need-hrule *want-hrule*) (format s "<hr>") (setq need-hrule nil))
					    (format s "<i>~a</i>: ~a<br>" 
						    p-label
						    (if (uri-p val)
							(pretty-aterm-sexp val)
							(if (stringp val)
							    val
							    val))))
					  ))
				     )))
				(t ""))))
	    (prog1 @@
	      (setq @@ (#"replaceAll"
			(#"replaceAll" 
			 (#"replaceAll" (#"replaceAll" @@ "<(\/div|br)>" (load-time-value (concatenate 'string (string #\linefeed) (string #\linefeed)))) "<\\S+?>" "")
			 "(<(div|font) .*?>)" "")
			"&\\S+?;" " ")))
	    ))))))

(defun tree-tooltip-text (entity kb)
  (#"replaceAll" (#"replaceAll"  (#"replaceAll" (tree-tooltip entity kb) "(<br>)|(<p>|<div[^>]*>)" "
")"&nbsp;" " ") "<[^<]+>" ""))


;; 		    (let ((sames (list-of-entity-names2 (#"getSames" (kb-kb kb) ent ))))
;; 		      (when sames
;; 			(format t "Same as: ~{~s~^, ~}~%" sames)))


(defun coalesce-disjoints (conjunction)
  (if (and (consp conjunction) (eq (car conjunction) 'and))
      (let ((nots (remove-if-not (lambda(c) (and (consp c) (eq (car c) 'not)  (atom (second c)))) (cdr conjunction))))
	(if (> (length nots) 1)
	    (append '(and)
	     (remove-if (lambda(c) (and (consp c) (eq (car c) 'not)  (atom (second c)))) (cdr conjunction))
	     (list (list* "<i>disjoint-with</i>" (mapcar 'second nots))))
	    conjunction))
      conjunction))

(defun property-attributes (type ent kb)
  (let ((pprops nil))
    (when (eq type :object-property)
      (when (#"isInverseFunctionalProperty" (kb-kb kb) ent)
	(push "Inverse Functional" pprops))
      (when (#"isSymmetricProperty" (kb-kb kb) ent) (push "Symmetric" pprops))
      (when (#"isTransitiveProperty" (kb-kb kb) ent) (push "Transitive" pprops)))
    (when (#"isFunctionalProperty" (kb-kb kb) ent) (push "Functional" pprops))
    (if pprops
	(format nil "~{<b><font color=\"#000080\">~a</font></b>~^, ~}<br>" pprops)
	"")))

(defun pretty-aterm-sexp (sexp)
  (if (stringp sexp)
      sexp;(uri-name-for-node (make-uri sexp))
      (if (uri-p sexp)
	  (uri-name-for-node sexp)
	  (if (atom sexp) 
	      sexp
	      (cond ((eq (car sexp) :subclass-of)
		     (pretty-aterm-sexp (third sexp)))
		    ((and (consp (car sexp)) (eq (caar sexp) :subclass-of))
		     (pretty-aterm-sexp 
		      `(:and ,sexp)))
		    ((equal (car sexp) '(:same))
		     `(equivalent-class ,@(rest (mapcar 'pretty-aterm-sexp (rest sexp)))))
		    ((equal (car sexp) '(:equivalent-classes))
		     `(equivalent-class ,@(mapcar 'pretty-aterm-sexp (rest sexp))))
		    ((= (length sexp) 1)
		     (pretty-aterm-sexp (car sexp)))
		    ((eq (car sexp) :literal)
		     (cond ((equal (fourth sexp) "http://www.w3.org/2001/XMLSchema#int")
			    (parse-integer (second sexp)))
			   ((equal (fourth sexp) "http://www.w3.org/2001/XMLSchema#double")
			    (float (read-from-string (second sexp))))
			   ((equal (fourth sexp) "http://www.w3.org/2001/XMLSchema#float")
			    (float (read-from-string (second sexp))))
			   ((equal (fourth sexp) "http://www.w3.org/2001/XMLSchema#string")
			    (prin1-to-string (second sexp)))
			   (t (prin1-to-string (second sexp)))))
		    ((and (eq (car sexp) 'and) (= (length sexp) 2))
		     (pretty-aterm-sexp (second sexp)))
		    ((and (eq (car sexp) 'and) (some (lambda(e)(and (consp e) (eq (car e) 'and))) (rest sexp)))
		     `(and
		       ,@(remove-duplicates 
			  (loop for el in (cdr sexp) 
			     if (and (consp el) (eq (car el) 'and))
			     append  (pretty-aterm-sexp (cdr el))
			     else if (stringp el) collect el;(uri-name-for-node (make-uri el))
			     else collect (pretty-aterm-sexp el))
			  :test 'equal)))
		    ((eq (car sexp) :subclass-of)
		     (list (car sexp) (second sexp)
			   (pretty-aterm-sexp (third sexp))))
		    ((and (eq (car sexp) :and) (= (length (rest sexp)) 1) 
			  (every 'consp (second sexp))
			  (eq (car (first (second sexp))) :mincardinality)
			  (eq (car (second (second sexp))) :maxcardinality))
		     (destructuring-bind (name card &rest ignore)
			 (cdar (cdadr sexp))
		       (list (uri-name-for-node (make-uri name)) 'exactly card )))
		    ((eq (car sexp) :cardinality)
		     (destructuring-bind (name card &rest ignore)
			 (cdr sexp)
		       (list (uri-name-for-node (make-uri name)) 'exactly card )))
		    ((and (member (car sexp) '(:and :or)) (= (length (rest sexp)) 1))
		     (let ((conjuncts (remove "_TOP_" (mapcar (lambda(e) (if (stringp e)
									     (pretty-aterm-sexp (make-uri e))
									     (pretty-aterm-sexp e))) (second sexp))
					      :test 'equal)))
		       (cond ((= (length conjuncts) 1)
			      (pretty-aterm-sexp (car conjuncts)))
			     (conjuncts  (pretty-aterm-sexp (list* (if (eq (car sexp) :and) 'and 'or)  conjuncts)))
			     (t nil))))
		    ((eq (car sexp) :mincardinality)
		     `( ,(uri-name-for-node (make-uri (second sexp))) min ,(third sexp)))
		    ((eq (car sexp) :hasvalue)
		     `(has ,(pretty-aterm-sexp (second sexp))))	; (uri-name-for-node (make-uri (second sexp)))))
		    ((eq (car sexp) :maxcardinality)
		     `( ,(uri-name-for-node (make-uri (second sexp))) max ,(third sexp)))
		    ((member (car sexp) '(:all-values-from :some-values-from))
		     `(,(if (stringp (second sexp))
			    (uri-name-for-node (make-uri (second sexp)))
			    (pretty-aterm-sexp (second sexp))) 
			,@(if (stringp (third sexp))
			      (progn
				(list (if (eq (car sexp) :all-values-from) "all" 'some)
				      (uri-name-for-node (make-uri (third sexp)))))
			      (if (and (consp (third sexp)) (eq (car (third sexp)) :hasvalue))
				  (list 'has (pretty-aterm-sexp (second (third sexp))))
				  (list (if (eq (car sexp) :all-values-from) 'all 'some)
					(pretty-aterm-sexp (third sexp)))))))
		    ((eq (car sexp) :not)
		     (if (consp (second sexp))
			 `(not ,(pretty-aterm-sexp (second sexp)))
			 `(not ,(uri-name-for-node (make-uri (second sexp))))))
	    

		    ;; ((eq (car sexp) 'and)
		    ;; 	     (loop for conjunct in (cdr sexp) append 
		    ;; 		  (if (and (consp conjunct) (eq (car conjunct) 'and))
		    ;; 		      (pretty-aterm-sexp (cadr conjunct))
		    ;; 		      (list (pretty-aterm-sexp conjunct)) )))
		    (t sexp))))))


(defun @@ (&rest args) (if (eq (car args) '@@) (progn (princ @@) (values)) (apply 'eval args)))

(defun maybe-hook-@@ ()
  (let ((sreh (and (find-package 'swank)
		   (find-symbol "*SLIME-REPL-EVAL-HOOKS*" 'swank))))
    (when (and sreh (boundp sreh))
      (eval `(pushnew '@@ ,sreh)))))

(setq test 
      '((:SUBCLASS-OF "ncbilsid:pubmed-classes:Investigator"
  (:AND
   ((:AND
     ((:MINCARDINALITY
       "ncbilsid:pubm
ed-predicates:Investigator_lastName" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_lastName" 1)))
    (:AND
     ((:MINCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_initials" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_initials" 1)))
    (:AND
     ((:MINCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_firstName" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_firstName" 1)))
    (:AND
     ((:MINCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_middleName" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_middleName" 1)))
    (:AND
     ((:MINCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_foreName" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_foreName" 1)))
    (:AND
     ((:MINCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_affiliation" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_affiliation" 1)))
    (:AND
     ((:MINCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_suffix" 1)
      (:MAXCARDINALITY
       "ncbilsid:pubmed-predicates:Investigator_suffix" 1))))))))