(in-package :cl-user)

(defmethod classtree-report ((kb kb) &key root stream include-instances merge-same dont-show (use-labels t))
  (let ((unsatisfiable (equivalents !owl:Nothing kb))
	(equivalents-seen (make-hash-table))
	(labels (and use-labels (rdfs-labels kb)))
	(inorder nil)
	(node2number (make-hash-table))
	(count 0)
	(me  (car (sparql '(:select (?me ) () (?me !rdf:type !owl:Ontology)) :kb kb :use-reasoner :jena :flatten t)))
	(props (sparql '(:select (?p ?o) () (?me !rdf:type !owl:Ontology) (?me ?p ?o)) :kb kb :use-reasoner :jena ))
	(loaded-from (kb-loaded-from kb)))
    (macrolet ((satisfiable-children (node kb)
		 `(set-difference (children ,node ,kb) unsatisfiable :test 'eq)))
      (let ((f stream))
	(labels ((node-number (node)
		   (or (prog1 (gethash node node2number) (princ "."))
		       (progn
			 (push node inorder)
			 (setf (gethash node node2number) (incf count)))))
		 (subtree (node)
		   (unless (or (gethash node equivalents-seen)
			       (member node dont-show))
		     (let ((children (satisfiable-children node kb)))
		       (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 "<li><a href='#item~a'>~a</a></li>" (node-number node)
				      (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))
			      )
			     ((and (null children) include-instances (instances node kb))
			      (format f "<a href='#item~a'>~a</a><ul style='border-left: thin solid #999999'>~%" (node-number node)
				      (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))
			      (loop for i in (direct-instances node kb)
				 do
				   (format f "<li><a href='#item~a'>~a</a>~%"
					   (node-number i)
					   (uri-name-for-node-with-equivalents i  kb labels  merge-same ))
				 )
			      (format f "</ul>~%"))
			     (t
			      (format f "<a href='#item~a'>~a</a><ul style='border-left: thin solid #999999'>~%" (node-number node)
				      (format nil "~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))))
			      (loop for child in children
				 do (subtree child))
			      (when include-instances
				(loop for i in (direct-instances node kb)
				   do
				   (format f "<a href='#item~a'>~a</a><ul style='border-left: thin solid #999999'>~%" (node-number i)
					   (uri-name-for-node i))
				   ))
			      (format f "</ul>~%")))))))
	  (format f "<ul>")
	  (subtree (or root !owl:Thing))
	  (format f "</ul>")
	  )))
    (reverse inorder)))


(defun annotation-property-html-list (kb count inorder stream)
  (let ((props
	 (loop for name being the hash-keys of (kb-name2entity kb)
	    using (hash-value type-entity)
	    when (eq (car type-entity) :annotation-property)
	    collect 
	    (multiple-value-bind (abbrev namespace)
		(maybe-abbreviate-namespace name)
	      (cons name (or namespace abbrev))))))
    (loop for prop in (sort props 'string-lessp :key 'cdr)
       do
       (format stream "<li><a href='#item~a'>~a</a> (~a)</li>~%"  (incf count)
	       (uri-name-for-node (make-uri (car prop)))
	       (cdr prop))
       (push (make-uri (car prop)) inorder)))
  (values count inorder))

(defmethod propertytree-report ((kb kb) &key stream (include-annotation-properties t) count (use-labels t) merge-same dont-show)
  (let ((role-taxonomy (#"getTaxonomy" (#"getRBox" (kb-kb kb))))
	(labels (and use-labels (rdfs-labels kb)))
	(inorder nil))
    (let ((f stream))
      (labels ((subtree (jnode kind)
		 (let ((node  (#"getName" jnode)))
		   (unless (stringp node) 
		     (setq node (aterm-to-sexp 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)))
		   (let* ((top (member node (list !owl:ObjectProperty !owl:AnnotationProperty !owl:DatatypeProperty !rdf:Property)))
			  (jchildren (#"getSubs" jnode))
			  (children (remove !owl:Nothing (mapcar (lambda(c)
								   (if (stringp c) c (aterm-to-sexp c)))
								 (mapcar #"getName" (set-to-list jchildren)))
					    :test 'equalp)))
		       (when top
			 (format f "<li><i>~a</i></li><ul style='border-left: thin solid #999999'>" (uri-name-for-node node)))
		       (cond ((and (null children) (not top))
			      (format f "<li><a href='#item~a'>~a</a></li>~%" (incf count) (uri-name-for-node node))
			      (push node inorder))
			     (t
			      (unless top
				(format f "<li><a href='#item~a'>~a</a></li><ul style='border-left: thin solid #999999'>" (incf count) (uri-name-for-node node))
				(push  node inorder))
			      (loop for jchild in (set-to-list jchildren)
				 do (subtree jchild kind))
			      (when (and (equal node !owl:AnnotationProperty) include-annotation-properties) 
				(multiple-value-setq (count inorder) (annotation-property-html-list kb count inorder f)))
			      (unless top
				(format f "</ul>~%"))))
		       (when top
			 (format f "</ul>" (uri-name-for-node node)))
		   ))))
	(format f "<ul>")
	(subtree (#"getTop" role-taxonomy) :annotation-property)
	(subtree (#"getTop" role-taxonomy) :datatype-property)
	(subtree (#"getTop" role-taxonomy) :object-property)
	(format f "</ul>")
	(reverse inorder)))
      ))

(defmethod write-ontology-report ((kb kb) &key root fname
				  include-instances merge-same dont-show (use-labels t) )
  
  (let* ((*current-labels* (rdfs-labels kb))
	 (onts  (sparql '(:select (?me ) () (?me !rdf:type !owl:Ontology)) :kb kb :use-reasoner :jena :flatten t))
	 (me  (car onts))
	 (loaded-from (kb-loaded-from kb))
	 (*want-hrule* nil))
    (with-open-file (f fname :direction :output :if-exists :supersede :if-does-not-exist :create)
      (write-string  "<html>" f)
      (format f "<head><title>~a</title></head>" loaded-from)
      (write-string "<style type='text/css'> ul { list-style-type: none; margin-left: 10px; padding-left:10px;} </style>" f)
      (loop for me in onts
	 for props = (sparql `(:select (?p ?o) () (,me ?p ?o)) :kb kb :use-reasoner :jena )
	 do
	 (if (> (length props) 1)
	     (format f "<h2>Ontology: ~a</h2>" (uri-full me))
	     (format f "<h3>Ontology: ~a</h3>" (uri-full me)))
	 (when (> (length props) 1) (format f "<h3><i>Ontology Annotations</i></h3>"))
	 (loop for ( p o) in props unless (eq p !rdf:type) 
	    do
	    (format f "<b>~a</b>: ~a<br>" (maybe-abbreviate-namespace (uri-full p))
		    (if (uri-p o) (uri-full o) o))))
      (format f "<hr><h3><i>Class Tree</i></h3>")
      (let ((inorder (classtree-report kb :stream f :root root :dont-show dont-show :include-instances include-instances)))
	(format f "<hr><h3><i>Property Tree</i></h3>")
	(let ((inorder2 (propertytree-report kb :stream f :count (1- (length inorder)))))
	  (format f "<hr><h3><i>Class Descriptions</i></h3>")
	  (loop for thing in inorder
	     for count from 1
	     do (format f "<a name='item~a'>~a<hr>~%" count (tree-tooltip kb (uri-full thing) :width 800)))
	  (format f "<h3><i>Property Descriptions</i></h3>")
	  (loop for thing in inorder2
	     for count from (length inorder)
	     do (format f "<a name='item~a'>~a<hr>~%" count (tree-tooltip kb (uri-full thing) :width 800))))
	(write-string  "</html> " f))
      fname)))