;;; directed graph package.
(provide 'digraph)

;; A directed graph is represented as vector of lists of integers.
;; The number of nodes in the graph is length of the vector.
;;
;; i'th list of the vector contains j <=> there is the edge from i to j.

(defalias 'digraph-descents 'aref)

(defun digraph-split-as-dag (g)
  "Returns 3 element vector of follows.

0. Directed acyclic graph generated by mergeing each strongly connected
components in G as new nodes.

1. Map from a node in g to a node in result.

2. Map from a node in result to nodes in g."
  (let* ((old-len (length g))
	 (new-to-olds (vconcat (digraph-tsort g)))
	 (new-len (length new-to-olds))
	 (old-to-new (make-vector old-len ()))
	 (i 0)
	 js res)
    (while (< i new-len)
      (setq js (aref new-to-olds i))
      (while js
	(aset old-to-new (car js) i)
	(setq js (cdr js)))
      (setq i (1+ i)))
    (setq i (1- new-len))
    (while (<= 0 i)
      (setq res (cons
		 (digraph-list-uniq
		  (apply
		   'nconc
		   (mapcar
		    (lambda (old)
		      (apply
		       'nconc
		       (mapcar 
			(lambda (old)
			  (if (= i (aref old-to-new old))
			      ()
			    (list (aref old-to-new old))))
			(aref g old))))
		    (aref new-to-olds i))))
		 res)
	    i (1- i)))
    (vector 
     (vconcat res)
     old-to-new
     new-to-olds)))

(defun digraph-split-as-forest (g)
  "Returns 3 element vector of follows.

0. Tree generated by merging nodes which have common descent node.

1. Map from a node in g to a node in result.

2. Map from a node in result to nodes in g."
  (let* ((tmp (digraph-split-as-dag g))
	 (d (aref tmp 0))
	 (g-to-d (aref tmp 1))
	 (d-to-g (aref tmp 2))
	 ;;(_ (error "%s" tmp))
	 (tmp (digraph-dag-to-forest d))
	 (f (aref tmp 0))
	 (d-to-f (aref tmp 1))
	 (f-to-d (aref tmp 2))
	 old-indices
	 new-indices
	 i)
    (setq i (1- (length g)))
    (while (<= 0 i)
      (setq old-indices (cons i old-indices)
	    i (1- i)))
    (setq i (1- (length f)))
    (while (<= 0 i)
      (setq new-indices (cons i new-indices)
	    i (1- i)))
    (vector
     f
     (vconcat
      (mapcar
       (lambda (gi) (aref d-to-f (aref g-to-d gi)))
       old-indices))
     (vconcat
      (mapcar
       (lambda (fi)
	 (apply
	  'nconc
	  (mapcar
	   (lambda (di) (aref d-to-g di))
	   (aref f-to-d fi))))
       new-indices)))))

(defun digraph-tsort (dep)
  "Sort nodes in a graph toporogicaly.

DEP is a vector of lists of integers and
digraph-tsort returns list of lists of integers.

The graph has (length DEP) nodes.

Dependency for i'th node is represented by i'th element of DEP.
If (aref DEP i) is a list (j1 j2 ... jn), it represents that i'th node
depends to j1, j2, ... and jn'th nodes of the graph.

A result of digraph-tsort is a sequence of sets of indexes for each
strongly connected nodes ordered by indepenedent to dependent as list
of lists of integers.

If (nth n result) contains an integer i, it represents the fact as
follows.

1. For all j in (nth n result) and j != i, i'th node depends to j'th
node and vice versa.

2. For all m < n and j in (nth m result), i'th nodes does not depend
to j'th node."
  (let* ((len (length dep))
	 (ord (make-vector len nil))
	 (i 0)
	 (res ()))
    (while (< i len)
      (if (not (aref ord i))
	  (setq res (nth 3 (digraph-tsort-visit dep len ord i 0 () res))))
      (setq i (1+ i)))
    res))

(defun digraph-tsort-visit (dep len ord i id stk res)
  (aset ord i id)
  (let ((js (aref dep i))
	(m id)
	(nid (1+ id))
	(stk (cons i stk))
	(res res))
    (while js
      (let* ((j (car js)) (jo (aref ord j)))
	(if jo
	    (setq m (if (< m jo) m jo))
	  (let* ((tmp (digraph-tsort-visit dep len ord j nid stk res))
		 (m0 (nth 0 tmp)))
	    (setq m (if (< m m0) m m0)
		  nid (nth 1 tmp)
		  stk (nth 2 tmp)
		  res (nth 3 tmp)))))
      (setq js (cdr js)))
    (if (= m id)
	(let* ((p (member i stk))
	       (nstk (cdr p))
	       (tmp stk))
	  (setcdr p ())
	  (while tmp
	    (aset ord (car tmp) len)
	    (setq tmp (cdr tmp)))
	  (list m nid nstk (cons stk res)))
      (list m nid stk res))))

(defun digraph-reverse (g)
  "Return graph with reversed edge."
  (let* ((len (length g))
	 (rev (make-vector len nil))
	 (i 0))
    (while (< i len)
      (let ((links (aref g i)))
	(while links
	  (if (not (member i (aref rev (car links))))
	      (aset rev (car links) (cons i (aref rev (car links)))))
	  (setq links (cdr links))))
      (setq i (1+ i)))
    rev))

(defun digraph-leaves (g)
  "Return list of leaves of G."
  (let* ((i (length g))
	(res ()))
    (while (< 0 i)
      (setq i (1- i))
      (if (null (aref g i))
	  (setq res (cons i res))))
    res))

(defun digraph-roots (g)
  "Return list of roots of G."
  (digraph-leaves (digraph-reverse g)))

;;; forest

(defun digraph-dag-to-forest (dag)
  "Convert a DAG(directed acyclic graph) to forest(set of trees)."
  (let* ((len (length dag))
	 (rev (digraph-reverse dag))
	 (forest (digraph-forest-make len))
	 (i 0))
    (while (< i len)
      (digraph-dag-forest-add-node forest i (aref rev i))
      (setq i (1+ i)))
    ;;(error "%s" forest)
    (digraph-forest-to-graph forest)))

(defun digraph-dag-forest-add-node (forest node links)
  (if (null links)
      (digraph-forest-add-tree forest node)
    (let ((parent (car links)))
      (setq links (cdr links))
      (digraph-forest-add-node forest parent node)
      (while links
	(digraph-forest-merge-node forest parent (car links))
	(setq links (cdr links)))))
  forest)

;; forest = [last-tree-id node-merge-map node-parent-map]
(defun digraph-forest-make (num)
  (vector 0 (make-vector num nil) (make-vector num nil)))
(defsubst digraph-forest-merge-map (forest) (aref forest 1))
(defsubst digraph-forest-parent-map (forest) (aref forest 2))

(defun digraph-forest-add-tree (forest node)
  (aset (digraph-forest-parent-map forest)
	node
	(aset forest 0 (1- (aref forest 0)))))

(defun digraph-forest-add-node (forest parent node)
  (aset (digraph-forest-parent-map forest) node parent))

(defun digraph-forest-node-id (forest node)
  (let ((merge-map (digraph-forest-merge-map forest)) tmp)
    (while (setq tmp (aref merge-map node))
      (setq node tmp))
    node))

(defun digraph-forest-tree-id (forest node)
  (setq node (digraph-forest-node-id forest node))
  (let ((parent-map (digraph-forest-parent-map forest))
	tmp)
    (while (<= 0 (setq tmp (aref parent-map node)))
      (setq node (digraph-forest-node-id forest tmp)))
    tmp))
  
(defun digraph-forest-root-p (forest node)
  (setq node (digraph-forest-node-id forest node))
  (< (aref (digraph-forest-parent-map forest) node) 0))

(defun digraph-forest-path-to-root (forest node)
  (setq node (digraph-forest-node-id forest node))
  (let ((parent-map (digraph-forest-parent-map forest))
	(path (list node)))
    (while (not (digraph-forest-root-p forest node))
      (setq node (digraph-forest-node-id forest (aref parent-map node))
	    path (cons node path)))
    path))

(defun digraph-forest-merge-node (forest n1 n2)
  (setq n1 (digraph-forest-node-id forest n1)
	n2 (digraph-forest-node-id forest n2))
  (let ((t1 (digraph-forest-tree-id forest n1))
	(t2 (digraph-forest-tree-id forest n2)))
    (if (= t1 t2)
	(let ((merge-map (digraph-forest-merge-map forest))
	      (p1 (digraph-forest-path-to-root forest n1))
	      (p2 (digraph-forest-path-to-root forest n2))
	      top)
	  (while (and p1 p2
		      (= (car p1) (car p2)))
	    (setq top (car p1)
		  p1 (cdr p1)
		  p2 (cdr p2)))
	  (setq p1 (nreverse p1))
	  (setq p2 (nreverse p2))
	  (while (and p1 p2)
	    (aset merge-map (car p2) (car p1))
	    (setq p1 (cdr p1)
		  p2 (cdr p2)))
	  (if (or p1 p2)
	      (let ((ns (nconc p1 p2)) n)
		(while ns
		  (aset merge-map (car ns) top)
		  (setq ns (cdr ns))))))
      (let ((merge-map (digraph-forest-merge-map forest))
	    (parent-map (digraph-forest-parent-map forest)))
	(while (and (not (digraph-forest-root-p forest n1))
		    (not (digraph-forest-root-p forest n2)))
	  (aset merge-map n2 n1)
	  (setq n1 (digraph-forest-node-id forest (aref parent-map n1))
		n2 (digraph-forest-node-id forest (aref parent-map n2))))
	(if (digraph-forest-root-p forest n2)
	    (aset merge-map n2 n1)
	  (aset merge-map n1 n2)))))
  forest)

(defun digraph-forest-to-graph (forest)
  (let* ((merge-map (digraph-forest-merge-map forest))
	 (parent-map (digraph-forest-parent-map forest))
	 (old-len (length merge-map))
	 (old-to-new (make-vector old-len nil))
	 new-to-olds
	 (new-len 0)
	 (i 0)
	 j
	 graph
	 )
    (while (< i old-len)
      (setq j (digraph-forest-node-id forest i))
      (if (aref old-to-new j)
	  (aset old-to-new i (aref old-to-new j))
	(progn
	  (aset old-to-new j new-len)
	  (aset old-to-new i new-len)
	  (setq new-len (1+ new-len))))
      (setq i (1+ i)))
    (setq new-to-olds (make-vector new-len nil)
	  graph (make-vector new-len nil))
    (setq i (1- old-len))
    (while (<= 0 i)
      (setq j (aref old-to-new i))
      (aset new-to-olds j
	    (cons i (aref new-to-olds j)))
      (setq i (1- i)))
    (setq i 0)
    (while (< i new-len)
      (setq j (aref parent-map (digraph-forest-node-id forest (car (aref new-to-olds i)))))
      (if (<= 0 j) (aset graph (aref old-to-new j)
			 (cons i (aref graph (aref old-to-new j)))))
      (setq i (1+ i)))
    (vector graph old-to-new new-to-olds)))

;;; utilities

(defun digraph-list-uniq (il)
  (if (null il)
      ()
    (if (member (car il) (cdr il))
	(digraph-list-uniq (cdr il))
      (cons (car il) (digraph-list-uniq (cdr il))))))

'(
(digraph-split-as-forest [nil nil nil nil nil nil nil nil nil nil (10) nil nil (12) (13) (0 1 2 3 4 5 6 7 8 9 10 11 13 14)])
[
 [(14 13 12 11 10 9 8 7 6 5 4 3 1) (2) nil nil nil nil nil nil nil nil nil nil nil nil nil]
 [14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 0]
 [(15) (14) (13) (12) (11) (10) (9) (8) (7) (6) (5) (4) (3) (2) (1) (0)]]

)