;; http://www.infovis-wiki.net/images/d/d7/Prefuse-tutorial-20061127-handout.pdf

(defclass pellet-abox ()
  ((abox :accessor abox :initarg :abox)
   (kb :accessor kb :initarg :kb)
   (about :accessor about :initarg :about)
   (nodes :accessor nodes)))

(defmethod nodes :around ((a pellet-abox))
  (if (slot-boundp a 'nodes)
      (call-next-method)
      (let ((table (make-hash-table :test 'equal)))
	(loop for node in (set-to-list (#"getNodes" (abox a)))
	   do (setf (gethash (#"getNameStr" node) table ) node))
	(setf (slot-value a 'nodes) table))))
  
(defmethod node-named ((a pellet-abox) name)
  (gethash name (nodes a) ))

(defmethod print-object ((a pellet-abox) stream)
  (format stream "#<~a ~a nodes>" (about a) (#"size" (#"getNodes" (abox a)))))

(defun to-hashset (individuals kb)
  (if individuals
       (let ((set (new 'hashset)))
	 (loop for i in individuals 
	      do
	      (#"add" set (get-entity i kb )))
	 set)
       (get-java-field (find-java-class 'org.mindswap.pellet.utils.SetUtils) "EMPTY_SET" t)))

(defun check-entity-consistency (thing kb &optional return-completion individuals)
  (let ((was (#"isKeepLastCompletion" (#"getABox" (kb-kb kb)))))
    (when return-completion
      (#"setKeepLastCompletion" (#"getABox" (kb-kb kb)) t))
    (#"isConsistent"
     (#"getABox" (kb-kb kb))
     (to-hashset individuals kb)
     (get-entity  (uri-full thing) kb)
     nil)
    (when return-completion
      (prog1
	  (make-instance 'pellet-abox :abox (#"getLastCompletion" (#"getABox" (kb-kb kb)))
			 :kb kb
			 :about (format nil "completion for consistency check of '~a' ~a"
					(let ((*annotation-query-reasoner* :none))
					  (car (rdfs-label thing kb)))
					thing)
			 )
	(#"setKeepLastCompletion" (#"getABox" (kb-kb kb)) was))
      )))

(defmethod longest-path ((a pellet-abox))
  (let ((longest 0)
	(winner nil))
    (maphash (lambda(name node)
	       (when (> (#"size" (#"getPath" node)) longest)
		 (setq longest (#"size" (#"getPath" node)))
		 (setq winner name)))
	     (nodes a))
    (let ((path (#"getPath" (node-named a winner))))
      (values (map 'list (lambda(el) (car (rdfs-label (#"toString" el) (kb a)))) (#"toArray" path))
	      winner))
    ))

(defmethod node-named-types ((a pellet-abox) node)
  (when (stringp node) (setq node (node-named a node )))
  (let ((types (mapcar 'aterm-to-named-class-only (set-to-list (#"getTypes" node)))))
    (remove-duplicates
     (loop for type in types 
	if (and (has-entity? !snap:MaterialEntity (kb a))
		(member type (list !<http://www.ifomis.org/bfo/1.1/snap#FiatObjectPart>
				   !<http://www.ifomis.org/bfo/1.1/snap#Object>
				   !<http://www.ifomis.org/bfo/1.1/snap#ObjectAggregate>)))
	collect  !snap:MaterialEntity
	else when type collect type))))

(defmethod spawns ((a pellet-abox))
  (let ((table (make-hash-table :test 'equalp))
	(cache (make-hash-table :test 'equalp)))
    (loop for node being the hash-values of (nodes a)
       for parent =  (#"getParent" node)
       unless (or (null parent) (equal (#"getNameStr" parent) "_C_"))
       do
	 (let* ((types (node-named-types a parent))
	      (most-specific (or (gethash types cache)
				(setf (gethash types cache)
				      (most-specific (kb a) types)))))
	 (incf (gethash most-specific table 0))))
    (let ((results 
	   (loop for k being the hash-keys of table
	      using (hash-value v) collect (list k (loop for e in k collect (rdfs-label e (kb a))) v))))
      (sort results '> :key 'third))))

(defmethod take-sample ((kb kb) &optional (seconds 60) (sortby "Time"))
  (unwind-protect 
       (progn
	 (log-info kb)
	 (#"clearCaches" (#"getABox" (kb-kb kb)) t)
	 (setq *inspector*
	       (make-instance 'sample-inspector :kb kb :object
			      (consistency-check-report
			       (capturing-log-to-string (t (pellet-loggers kb)) 
							(unwind-protect
							     (ignore-errors
							       (with-pellet-timeout (kb seconds)
								 (check kb)))
							  (#"resetAll" (get-java-field (kb-kb kb) "timers"))
							  ))
			       kb sortby)))
	 )
    (log-off kb)
    ))

(defun consistency-check-report (string kb &optional (sortby "Time"))
  (with-input-from-string (s string)
    (let ((parsed (loop for line1 = (read-line s nil :eof)
		     for line2 = (read-line s nil :eof)
		     until (or (eq  line1 :eof) (eq line2 :eof))
		     append
		     (let ((uri (mapcar 'make-uri (mapcar 'car (all-matches line1 "(http://\\S*)" 1))))
			   (measured (all-matches line2 "([a-zA-Z]+): (\\d+)" 1 2)))
		       (if uri
			   (list (list* (list (car uri) (rdfs-label (car uri) kb))  measured)))))))
      (sort 
       (copy-list parsed)
       '>
       :key (lambda(el) (read-from-string (second (assoc sortby el :test 'equalp ))))))))

(defun aterm-to-named-class-only (aterm)
  "return uri or nil if not a simple named class"
  (let ((type (case (#"getType" aterm)
		(#.(get-java-field 'aterm "APPL") :appl)
		(otherwise nil))))
    (if type
	(if (> (#"getLength" (#"getArguments" aterm)) 0)
	    nil
	    (if (#"matches" (#"getName" aterm) "^http:.*")
		(make-uri (#"getName" aterm)))))))

(defun describe-out-edges (abox node)
  (if (stringp node) (setq node (node-named abox node)))
  (let ((edgelist (#"getOutEdges" node)))
    (loop for edgeno below (#"size" edgelist)
	 for edge = (#"edgeAt" edgelist edgeno)
	 for relation = (#"getRole" edge)
	 for object = (#"getTo" edge)
       do (format t "~a -> ~a: ~a ~%"
		  (or (car (rdfs-label (aterm-to-sexp (#"getName" relation)) (kb abox))) (aterm-to-sexp (#"getName" relation)))
		  (#"getNameStr" object)
		  (node-type-description abox object)))))

(defmethod node-type-description ((abox pellet-abox) node &optional (style :line))
  (if (stringp node) (setq node (node-named abox node)))
  (format nil (ecase style (:line "<~{~a~^, ~}>") (:stack "~{~a~^~%~}"))
	  (loop for term in (most-specific (kb abox) (node-named-types abox node))
		     collect (or (car (rdfs-label term (kb abox))) term))))

(defmethod make-completion-graph ((abox pellet-abox) &optional (depth 3))
  (#"setDismissDelay" (#"sharedInstance" 'tooltipmanager) 300000)
  (#"setInitialDelay" (#"sharedInstance" 'tooltipmanager) 100)
  (let ((g (make-graph))
	(obj-node-assoc nil))
    (let ((cnode (#"addNode" g)))
      ;(#"addColumns" (#"getEdgeTable" g) (get-java-field 'prefuse.util.GraphLib "LABEL_SCHEMA"))
      (#"setString" cnode "label" (format nil "Class:~%~a" (node-type-description abox (node-named abox "_C_") :stack)))
      (push (cons (node-named abox "_C_") (#"getRow" cnode)) obj-node-assoc)      
      (labels ((add-children (from gfrom depth)
		 (unless (eql depth 0)
		   (let ((edgelist (ignore-errors (#"getOutEdges" from))))
		     (when edgelist
		     (loop for edgeno below (#"size" edgelist)
			for edge = (#"edgeAt" edgelist edgeno)
			for relation = (#"getRole" edge)
			for to = (#"getTo" edge)
			for gto = (#"addNode" g)
			do ;(format t "~a -> ~a: ~a ~%" (or (car (rdfs-label (aterm-to-sexp (#"getName" relation)) (kb abox))) (aterm-to-sexp (#"getName" relation))))
			  (#"setString" gto "label"   (format nil "~a:~%~{~a~^~%~}"
							      (or (car (rdfs-label (aterm-to-sexp (#"getName" relation)) (kb abox))) (aterm-to-sexp (#"getName" relation)))
							      (loop for term in (most-specific (kb abox) (node-named-types abox to))
								 collect (or (car (rdfs-label term (kb abox))) term))))
			  (push (cons to (#"getRow" gto)) obj-node-assoc)
			  (#"addEdge" g gfrom gto)
			  ;(#"setString" (#"addEdge" g gfrom gto) "label" "foo")
			  (add-children to gto (- depth 1))))))))
	(add-children (node-named abox "_C_") cnode (- depth 1))
	(setq @ (make-instance 'completion-graph :graph g :layout 'ForceDirectedLayout :root cnode :continuous-layout 20
		       :obj-node-assoc obj-node-assoc
		       :controls (list (make-tooltip-control 
					(kb abox)
					'completion-node-tooltip 
					(lambda(item) t)
					(lambda(item)
					  (most-specific
					   (kb abox)
					   (node-named-types abox (car (rassoc (#"getRow" (#"getSourceTuple" item))
							       obj-node-assoc)))))))
		       :kb (kb abox) :abox abox
		       :force-parameters `((:NBODYFORCE :GRAVITATIONALCONSTANT -30)
					   (:NBODYFORCE :barneshuttheta .2))
		       ))
	 ;; make the tooltips last longer
	))))

(defclass completion-graph (prefuse-graph)
  ((kb :initarg :kb)
   (abox :initarg :abox)))

(defmethod node-clicked ((this completion-graph) node mouse-event)
  (with-slots (obj-node-assoc kb abox) this
    (let ((node (car (rassoc (#"getRow" node) obj-node-assoc))))
      (let* ((*print-case* :downcase)
	     (*current-labels* (rdfs-labels kb))
	     (*uri-name-html* nil))
	(declare (special *current-labels*))
	(oinspect (cons node
			(sort (mapcar (lambda(e) (format nil "~a" (pretty-aterm-sexp (aterm-to-sexp e))))
				      (set-to-list (#"getTypes" node)))
			      'string-greaterp)) t)))))

(defclass sample-inspector (inspector-window)
  ((kb :initarg :kb :accessor kb)
   (treedepth :initarg :treedepth :accessor treedepth :initform 4)))

(defmethod initialize-instance :after ((this sample-inspector) &key (name "Inspector")) 
  (with-slots (jframe object) this
    (#"setTitle" jframe (format nil "Sample on ~a" (kb-loaded-from (kb this))))))

(defmethod oojump ((inspector sample-inspector) fieldvalue row push)
  (make-completion-graph (check-entity-consistency (car row) (kb inspector) t) (treedepth inspector)))

(defmethod oinspect-data ((inspector sample-inspector) data)
  (cons '("URI" "Label" "Tree depth" "Number of nodes" "Time")
	(mapcar (lambda(el) (list (caar el) (car (second (car el))) (second (second el)) (second (third el)) (second (fourth el)) ))
		data))
  )

(defmethod make-inspector-buttons ((inspector sample-inspector))
  (list
   (make-swing-button "3" #'(lambda (evt)
			      (declare (ignore evt))
			      (setf (treedepth inspector) 3)
			      (multiple-value-bind (field row)
				  (selected-field inspector)
				(oojump inspector field row nil))))
   (make-swing-button "4" #'(lambda (evt)
			      (declare (ignore evt))
			      (setf (treedepth inspector) 4)
			      (multiple-value-bind (field row)
				  (selected-field inspector)
				(oojump inspector field row nil))))
   (make-swing-button "5" #'(lambda (evt)
			      (declare (ignore evt))
			      (setf (treedepth inspector) 5)
			      (multiple-value-bind (field row)
				  (selected-field inspector)
				(oojump inspector field row nil))))
   (make-swing-button "6" #'(lambda (evt)
			      (declare (ignore evt))
			      (setf (treedepth inspector) 6)
			      (multiple-value-bind (field row)
				  (selected-field inspector)
				(oojump inspector field row nil))))))

(defun completion-node-tooltip (kb types &aux (width 500))
  (let* ((*current-labels* (rdfs-labels kb)))
    (declare (special *current-labels*))
    (with-output-to-string (s)
      (format s "<html>")
      (loop for type in types
	 for comment = (let ((it (rdfs-comment type kb))) (and it  (#"replaceAll" it "<" "&lt;")))
	 for label =  (or (car (rdfs-label type kb)) (#"replaceAll" (uri-full type) "^.*(#|/)" ""))
	 when (has-entity? type kb) ; allow for xsd, rdfs terms
	 do
	 (format s "<div style=\"width:~a\">~a<i>~a</i>~a</div>" 
		 width
		 (format nil "<b><i>~a</i></b><br>" label)
		 (or ""(if (and comment  (not (equal comment "")))
		     (format nil "<div style=\"margin-left:5px;margin-top:2px;margin-bottom:2px\">~a</div>" comment)
		     ""))
		 (let ((form (coalesce-disjoints (pretty-aterm-sexp
						  (mapcar 
						   'aterm-to-sexp
						   (setq axioms 
							 (set-to-list 
							  (#"getAxioms" (#"getTBox" (kb-kb kb)) (get-entity  type kb)))))))))
		   (format nil "<font color=\"#000080\">~a</font><br>" 
			   (let ((*print-right-margin* (floor width 8)))
			     (if (listp form)
				 (format-sexp-for-tooltip (or form "Thing"))
				 (format-sexp-for-tooltip form)))))))
      (format s "</html>"))))