+++ /dev/null
-;;; 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)]]
-
-)
\ No newline at end of file
projects / elisp / flim.git / blobdiff