(eval-when (:compile-toplevel)
  (ql:quickload :s-xml))

(defpackage graph-algorithms
  (:nicknames :ga)
  (:use #:cl))

(in-package :graph-algorithms)

(declaim (optimize (debug 3) (speed 0) (space 0)))


;; graph IO

(defun parse-graph (file)
  "Return nodes and edges from FILE."
  (flet ((parse-id (str) (parse-integer str :start 1)))
    (let (nodes edges)
      (dolist (object (cdr (s-xml:parse-xml-file file)))
	(ecase (caar object)
	  (:|node| (push (cons (parse-id (getf (cdar object) :|id|))
			       (getf (cdar object) :|name|))
			 nodes))
	  (:|edge| (push (cons (parse-id (getf (cdar object) :|source|))
			       (parse-id (getf (cdar object) :|target|)))
			 edges))))
      (loop for (id . descr) in nodes
	    collect (list* id descr
			   (loop for (from . to) in edges
				 when (eq id from)
				   collect to))))))

(defun incoming (graph node)
  (loop for (other desc . out) in graph
	when (member node out)
	  collect other))

(defun outgoing (graph node)
  (cddr (assoc node graph)))

(defun outdegree (graph node)
  (length (outgoing graph node)))

(defun edges (graph)
  (loop for (a _ . towards) in graph
	append (loop for b in towards
		     collect (cons a b))))


;; page rank

(defun counter (n)
  "Return nil N times, then t."
  (lambda (&rest _)
    (declare (ignore _))
    (>= 0 (decf n))))

(defun page-rank (graph terminate-p d)
  (let ((chapters (mapcar #'car graph))
	(relevance (make-hash-table)))
    (dolist (chapter chapters)
      (setf (gethash chapter relevance)
	    (float (/ (length chapters)))))
    (loop until (funcall terminate-p relevance) do
      (let ((temp (make-hash-table)))
	(loop for S in chapters do
	  (setf (gethash S temp)
		(+ (* (loop for R in (incoming graph S)
			    sum (/ (gethash R relevance)
				   (outdegree graph R)))
		      d)
		   (/ (- 1 d) (length chapters)))))
	(setf relevance temp)))
    (let (results)
      (maphash (lambda (id val)
		 (push (cons (cadr (assoc id graph)) val)
		       results))
	       relevance)
      results)))


;; HITS

(defun magnitude (table)
  (let ((sum 0))
    (maphash (lambda (key val)
	       (declare (ignore key))
	       (incf sum (* val val)))
	     table)
    (sqrt sum)))

(defun normalize (table)
  (declare (optimize (debug 3)))
  (let ((mag (magnitude table)))
    (maphash (lambda (key val)
	       (setf (gethash key table)
		     (/ val mag)))
	     table))
  (assert (let ((eta 0.001))
	    (< (- 1 eta) (magnitude table) (+ 1 eta)))))

(defparameter *hits-init-hub-weight* 1)
(defparameter *hits-init-authority* 1)
(defparameter *hits-init-normalize* t)
(defparameter *hits-mode* :authorities)

(defun hits (graph terminate-p)
  (let ((hub-weights (make-hash-table))
	(authorities (make-hash-table))
	(chapters (mapcar #'car graph)))
    ;; Initialize hub heights yᵖ and authorities xᵖ of all chapters p
    ;; to 1
    (dolist (chapter chapters)
      (setf (gethash chapter hub-weights) (coerce *hits-init-hub-weight* 'double-float))
      (setf (gethash chapter authorities) (coerce *hits-init-authority* 'double-float)))
    ;; While maximum number of iterations not reached...
    (loop until (let ((use (ecase *hits-mode*
			     (:hub-weights hub-weights)
			     (:authorities authorities))))
		  (funcall terminate-p use))
	  do (dolist (p chapters)
	       (setf (gethash p authorities)
		     (loop for q in (incoming graph p)
			   sum (gethash q hub-weights))))
	     (dolist (p chapters)
	       (setf (gethash p hub-weights)
		     (loop for q in (outgoing graph p)
			   sum (gethash q authorities))))
	     (when *hits-init-normalize*
	       ;; Normalize such that Σₚxᵖ² = 1 and Σₚyᵖ² = 1
	       (normalize hub-weights)
	       (normalize authorities)))
    ;; Extract data out of hash tables
    (let ((use (ecase *hits-mode*
		 (:hub-weights hub-weights)
		 (:authorities authorities)))
	  results)
      (dolist (node graph)
	(push (cons (cadr node) (gethash (car node) use))
	      results))
      results)))


;; search analysis

(defun print-results (results)
  (declare (list results))
  (fresh-line)
  (dolist (ent (sort results #'> :key #'cdr))
    (format t "~%~F ~A" (cdr ent) (car ent))))

(defun vary-dampening (graph start end step)
  (let ((files (loop for id in (mapcar #'car graph)
		     collect (open (format nil "v~D.dat" id)
				   :direction :output
				   :if-exists :supersede
				   :if-does-not-exist :create))))
    (unwind-protect
	 (loop for d from start to end by step do
	   (loop with results = (page-rank graph (counter 1000) d)
		 for node in (mapcar #'cadr graph)
		 for file in files
		 do (format file "~&~F ~F" d (cdr (assoc node results)))))
      (mapc #'close files))))

(defun track-progress (graph steps searcher &aux (step 0))
  (let ((files (loop for id in (mapcar #'car graph)
		     collect (cons id (open (format nil "p~D.dat" id)
					    :direction :output
					    :if-exists :supersede
					    :if-does-not-exist :create)))))
    (flet ((logger (results)
	     (maphash
	      (lambda (id rel)
		(format (cdr (assoc id files))
			"~%~D ~F" step rel))
	      results)
	     (> (incf step) steps)))
      (unwind-protect (funcall searcher graph #'logger)
	(mapc #'close (mapcar #'cdr files))))))


;; network 

(defun connected-graph (graph node)
  (let ((stack (list node)) reachable)
    (loop while stack do
      (dolist (node* (outgoing graph (pop stack)))
	(unless (member node* reachable)
	  (push node* reachable)
	  (push node* stack))))
    (loop for node in reachable
	  collect (assoc node graph))))

(defun get-id (graph label)
  (car (find label graph :key #'cadr :test #'string-equal)))

(defvar *path-cache* (make-hash-table :test #'equal))

(defun floyd-warshal (graph)
  "Populate *DIST-CACHE* with shortest paths."
  (let ((dist (make-array (list (length graph)
				(length graph))
			  :initial-element most-positive-fixnum
			  :element-type 'fixnum))
	(next (make-array (list (length graph)
				(length graph))
			  :initial-element nil
			  :element-type 'list)))
    (dolist (edge (edges graph))
      (setf (aref dist (car edge) (cdr edge)) 1)
      (setf (aref next (car edge) (cdr edge)) (list (cdr edge))))
    (dolist (vertex (mapcar #'car graph))
      (setf (aref dist vertex vertex) 0)
      ;; We are not interested in self-edges:
      ;; (setf (aref next vertex vertex) vertex)
      )
    (dotimes (i (length graph))
      (dotimes (j (length graph))
	(dotimes (k (length graph))
	  (when (= (+ (aref dist i k) (aref dist k j))
		   (aref dist i j))
	    (assert (every #'atom (aref next i j)))
	    (assert (every #'atom (aref next i k)))
	    (setf (aref next i j)
		  (delete-duplicates
		   (append (aref next i j) (aref next i k)))))
	  (when (< (+ (aref dist i k) (aref dist k j))
		   (aref dist i j))
	    (setf (aref dist i j)
		  (+ (aref dist i k) (aref dist k j)))
	    (setf (aref next i j) (aref next i k)))
	  (assert (every #'atom (aref next i j))))))
    (dotimes (u (length graph))
      (dotimes (v (length graph))
	(labels ((walk (w)
		   (declare (type atom w))
		   (if (eq w v) (list (list v))
		       (loop for x in (aref next w v)
			     append (loop for y in (walk x)
					  collect (cons w y))))))
	  (setf (gethash (cons u v) *path-cache*)
		(and (aref next u v) (walk u))))))))

(defun shortest-paths (graph a b)
  (multiple-value-bind (paths ok)
      (gethash (cons a b) *path-cache*)
    (when ok (return-from shortest-paths paths)))
  (when (listp a) (setf a (car a)))
  (when (listp b) (setf b (car b)))
  (loop with paths = (list (list a)) do
    (unless paths
      (setf (gethash (cons a b) *path-cache*) nil)
      (return nil))
    ;; (assert (not (null paths)))
    (loop for path in paths
	  append (loop for n in (cddr (assoc (car path) graph))
		       unless (member n path)
			 collect (cons n path))
	    into extended
	  finally (setq paths extended))
    (when (member b paths :key #'car)
      (let ((paths (remove-if (lambda (path)
				(not (eq (car path) b)))
			      paths)))
	(setf (gethash (cons a b) *path-cache*)
	      paths)
	(return paths)))))

(defun distance (graph a b)
  (let ((paths (shortest-paths graph a b)))
    (assert (or (null paths) (apply #'= (mapcar #'length paths))))
    (if paths (1- (length (first paths)))
	(1- (length graph)))))

(defun degree-centrality (graph node)
  (/ (length (cddr (assoc node graph)))
     (length graph)))

(defun betweenness-centrality (graph node)
  (* (/ 2 (* (- (length graph) 1) (- (length graph) 2)))
     (loop with others = (remove node (mapcar #'car graph))
	   for a in others
	   sum (loop for b in (remove a others)
		     for paths = (shortest-paths graph a b)
		     when paths
		     sum (/ (loop for path in paths
				  count (member node path))
			    (length paths))))))

(defun closness-centrality (graph node)
  (/ (loop for other in (remove node (mapcar #'car graph))
	   sum (distance graph node other))
     (- (length graph) 1)))

;; (defun closness-centrality* (graph node)
;;   (let ((graph* (connected-graph graph node)))
;;     (/ (loop for other in (remove node (mapcar #'car graph*))
;; 	     sum (/ (distance graph* node other)))
;;        (- (length graph*) 1))))

(defun analyse-graph (graph)
  (dolist (node (reverse graph))
    (format t "~%~A ~F ~F ~F"
	    (substitute #\_ #\Space (cadr node))
	    (degree-centrality graph (car node))
	    (betweenness-centrality graph (car node))
	    ;; (closness-centrality graph (car node))
	    ;; (closness-centrality* graph (car node))
	    (- 1 (/ (closness-centrality graph (car node))
		    (loop for other in (mapcar #'car graph)
			  maximize (closness-centrality graph other)))))))



;; tests

(eval-when (:execute)

  (let ((d 4/5))
    (let ((results (page-rank (parse-graph "graph.xml") (counter 1000) d)))
      (format t "~2%* d = ~A" d)
      (print-results results)))

  (let ((d 4/5))
    (let ((results (page-rank (parse-graph "kite.xml") (counter 1000) d)))
      (format t "~2%* d = ~A" d)
      (print-results results)))

  (vary-dampening nodes (parse-graph "graph.xml") 1/10 1 1)

  (track-progress (parse-graph "graph.xml") 1000
		  (lambda (graph test)
		    (page-rank graph test 4/5)))

  ;; >gnuplot -p -e 'set xlabel "CD"; set ylabel "CB"; set zlabel "CC"; splot "-" u 2:3:4:1 with labels not'
  (analyse-graph (parse-graph "kite.xml"))

  

  (let ((*hits-init-hub-weight* 1)
	(*hits-init-authority* 1)
	(*hits-init-normalize* t)
	(*hits-mode* :authorities))
    (print-results (hits (parse-graph "graph2.xml") (counter 1000)))
    ;; (track-progress (parse-graph "graph2.xml") 1000 #'hits)
    )

  (analyse-graph (parse-graph "graph2.xml"))

  (floyd-warshal (parse-graph "graph2.xml"))
  
  )