digraph.el

   1 ;;; directed graph package.
   2 (provide 'digraph)
   3
   4 ;; A directed graph is represented as vector of lists of integers.
   5 ;; The number of nodes in the graph is length of the vector.
   6 ;;
   7 ;; i'th list of the vector contains j <=> there is the edge from i to j.
   8
   9 (defalias 'digraph-descents 'aref)
  10
  11 (defun digraph-split-as-dag (g)
  12   "Returns 3 element vector of follows.
  13
  14 0. Directed acyclic graph generated by mergeing each strongly connected
  15 components in G as new nodes.
  16
  17 1. Map from a node in g to a node in result.
  18
  19 2. Map from a node in result to nodes in g."
  20   (let* ((old-len (length g))
  21          (new-to-olds (vconcat (digraph-tsort g)))
  22          (new-len (length new-to-olds))
  23          (old-to-new (make-vector old-len ()))
  24          (i 0)
  25          js res)
  26     (while (< i new-len)
  27       (setq js (aref new-to-olds i))
  28       (while js
  29         (aset old-to-new (car js) i)
  30         (setq js (cdr js)))
  31       (setq i (1+ i)))
  32     (setq i (1- new-len))
  33     (while (<= 0 i)
  34       (setq res (cons
  35                  (digraph-list-uniq
  36                   (apply
  37                    'nconc
  38                    (mapcar
  39                     (lambda (old)
  40                       (apply
  41                        'nconc
  42                        (mapcar
  43                         (lambda (old)
  44                           (if (= i (aref old-to-new old))
  45                               ()
  46                             (list (aref old-to-new old))))
  47                         (aref g old))))
  48                     (aref new-to-olds i))))
  49                  res)
  50             i (1- i)))
  51     (vector
  52      (vconcat res)
  53      old-to-new
  54      new-to-olds)))
  55
  56 (defun digraph-split-as-forest (g)
  57   "Returns 3 element vector of follows.
  58
  59 0. Tree generated by merging nodes which have common descent node.
  60
  61 1. Map from a node in g to a node in result.
  62
  63 2. Map from a node in result to nodes in g."
  64   (let* ((tmp (digraph-split-as-dag g))
  65          (d (aref tmp 0))
  66          (g-to-d (aref tmp 1))
  67          (d-to-g (aref tmp 2))
  68          ;;(_ (error "%s" tmp))
  69          (tmp (digraph-dag-to-forest d))
  70          (f (aref tmp 0))
  71          (d-to-f (aref tmp 1))
  72          (f-to-d (aref tmp 2))
  73          old-indices
  74          new-indices
  75          i)
  76     (setq i (1- (length g)))
  77     (while (<= 0 i)
  78       (setq old-indices (cons i old-indices)
  79             i (1- i)))
  80     (setq i (1- (length f)))
  81     (while (<= 0 i)
  82       (setq new-indices (cons i new-indices)
  83             i (1- i)))
  84     (vector
  85      f
  86      (vconcat
  87       (mapcar
  88        (lambda (gi) (aref d-to-f (aref g-to-d gi)))
  89        old-indices))
  90      (vconcat
  91       (mapcar
  92        (lambda (fi)
  93          (apply
  94           'nconc
  95           (mapcar
  96            (lambda (di) (aref d-to-g di))
  97            (aref f-to-d fi))))
  98        new-indices)))))
  99
 100 (defun digraph-tsort (dep)
 101   "Sort nodes in a graph toporogicaly.
 102
 103 DEP is a vector of lists of integers and
 104 digraph-tsort returns list of lists of integers.
 105
 106 The graph has (length DEP) nodes.
 107
 108 Dependency for i'th node is represented by i'th element of DEP.
 109 If (aref DEP i) is a list (j1 j2 ... jn), it represents that i'th node
 110 depends to j1, j2, ... and jn'th nodes of the graph.
 111
 112 A result of digraph-tsort is a sequence of sets of indexes for each
 113 strongly connected nodes ordered by indepenedent to dependent as list
 114 of lists of integers.
 115
 116 If (nth n result) contains an integer i, it represents the fact as
 117 follows.
 118
 119 1. For all j in (nth n result) and j != i, i'th node depends to j'th
 120 node and vice versa.
 121
 122 2. For all m < n and j in (nth m result), i'th nodes does not depend
 123 to j'th node."
 124   (let* ((len (length dep))
 125          (ord (make-vector len nil))
 126          (i 0)
 127          (res ()))
 128     (while (< i len)
 129       (if (not (aref ord i))
 130           (setq res (nth 3 (digraph-tsort-visit dep len ord i 0 () res))))
 131       (setq i (1+ i)))
 132     res))
 133
 134 (defun digraph-tsort-visit (dep len ord i id stk res)
 135   (aset ord i id)
 136   (let ((js (aref dep i))
 137         (m id)
 138         (nid (1+ id))
 139         (stk (cons i stk))
 140         (res res))
 141     (while js
 142       (let* ((j (car js)) (jo (aref ord j)))
 143         (if jo
 144             (setq m (if (< m jo) m jo))
 145           (let* ((tmp (digraph-tsort-visit dep len ord j nid stk res))
 146                  (m0 (nth 0 tmp)))
 147             (setq m (if (< m m0) m m0)
 148                   nid (nth 1 tmp)
 149                   stk (nth 2 tmp)
 150                   res (nth 3 tmp)))))
 151       (setq js (cdr js)))
 152     (if (= m id)
 153         (let* ((p (member i stk))
 154                (nstk (cdr p))
 155                (tmp stk))
 156           (setcdr p ())
 157           (while tmp
 158             (aset ord (car tmp) len)
 159             (setq tmp (cdr tmp)))
 160           (list m nid nstk (cons stk res)))
 161       (list m nid stk res))))
 162
 163 (defun digraph-reverse (g)
 164   "Return graph with reversed edge."
 165   (let* ((len (length g))
 166          (rev (make-vector len nil))
 167          (i 0))
 168     (while (< i len)
 169       (let ((links (aref g i)))
 170         (while links
 171           (if (not (member i (aref rev (car links))))
 172               (aset rev (car links) (cons i (aref rev (car links)))))
 173           (setq links (cdr links))))
 174       (setq i (1+ i)))
 175     rev))
 176
 177 (defun digraph-leaves (g)
 178   "Return list of leaves of G."
 179   (let* ((i (length g))
 180         (res ()))
 181     (while (< 0 i)
 182       (setq i (1- i))
 183       (if (null (aref g i))
 184           (setq res (cons i res))))
 185     res))
 186
 187 (defun digraph-roots (g)
 188   "Return list of roots of G."
 189   (digraph-leaves (digraph-reverse g)))
 190
 191 ;;; forest
 192
 193 (defun digraph-dag-to-forest (dag)
 194   "Convert a DAG(directed acyclic graph) to forest(set of trees)."
 195   (let* ((len (length dag))
 196          (rev (digraph-reverse dag))
 197          (forest (digraph-forest-make len))
 198          (i 0))
 199     (while (< i len)
 200       (digraph-dag-forest-add-node forest i (aref rev i))
 201       (setq i (1+ i)))
 202     ;;(error "%s" forest)
 203     (digraph-forest-to-graph forest)))
 204
 205 (defun digraph-dag-forest-add-node (forest node links)
 206   (if (null links)
 207       (digraph-forest-add-tree forest node)
 208     (let ((parent (car links)))
 209       (setq links (cdr links))
 210       (digraph-forest-add-node forest parent node)
 211       (while links
 212         (digraph-forest-merge-node forest parent (car links))
 213         (setq links (cdr links)))))
 214   forest)
 215
 216 ;; forest = [last-tree-id node-merge-map node-parent-map]
 217 (defun digraph-forest-make (num)
 218   (vector 0 (make-vector num nil) (make-vector num nil)))
 219 (defsubst digraph-forest-merge-map (forest) (aref forest 1))
 220 (defsubst digraph-forest-parent-map (forest) (aref forest 2))
 221
 222 (defun digraph-forest-add-tree (forest node)
 223   (aset (digraph-forest-parent-map forest)
 224         node
 225         (aset forest 0 (1- (aref forest 0)))))
 226
 227 (defun digraph-forest-add-node (forest parent node)
 228   (aset (digraph-forest-parent-map forest) node parent))
 229
 230 (defun digraph-forest-node-id (forest node)
 231   (let ((merge-map (digraph-forest-merge-map forest)) tmp)
 232     (while (setq tmp (aref merge-map node))
 233       (setq node tmp))
 234     node))
 235
 236 (defun digraph-forest-tree-id (forest node)
 237   (setq node (digraph-forest-node-id forest node))
 238   (let ((parent-map (digraph-forest-parent-map forest))
 239         tmp)
 240     (while (<= 0 (setq tmp (aref parent-map node)))
 241       (setq node (digraph-forest-node-id forest tmp)))
 242     tmp))
 243
 244 (defun digraph-forest-root-p (forest node)
 245   (setq node (digraph-forest-node-id forest node))
 246   (< (aref (digraph-forest-parent-map forest) node) 0))
 247
 248 (defun digraph-forest-path-to-root (forest node)
 249   (setq node (digraph-forest-node-id forest node))
 250   (let ((parent-map (digraph-forest-parent-map forest))
 251         (path (list node)))
 252     (while (not (digraph-forest-root-p forest node))
 253       (setq node (digraph-forest-node-id forest (aref parent-map node))
 254             path (cons node path)))
 255     path))
 256
 257 (defun digraph-forest-merge-node (forest n1 n2)
 258   (setq n1 (digraph-forest-node-id forest n1)
 259         n2 (digraph-forest-node-id forest n2))
 260   (let ((t1 (digraph-forest-tree-id forest n1))
 261         (t2 (digraph-forest-tree-id forest n2)))
 262     (if (= t1 t2)
 263         (let ((merge-map (digraph-forest-merge-map forest))
 264               (p1 (digraph-forest-path-to-root forest n1))
 265               (p2 (digraph-forest-path-to-root forest n2))
 266               top)
 267           (while (and p1 p2
 268                       (= (car p1) (car p2)))
 269             (setq top (car p1)
 270                   p1 (cdr p1)
 271                   p2 (cdr p2)))
 272           (setq p1 (nreverse p1))
 273           (setq p2 (nreverse p2))
 274           (while (and p1 p2)
 275             (aset merge-map (car p2) (car p1))
 276             (setq p1 (cdr p1)
 277                   p2 (cdr p2)))
 278           (if (or p1 p2)
 279               (let ((ns (nconc p1 p2)) n)
 280                 (while ns
 281                   (aset merge-map (car ns) top)
 282                   (setq ns (cdr ns))))))
 283       (let ((merge-map (digraph-forest-merge-map forest))
 284             (parent-map (digraph-forest-parent-map forest)))
 285         (while (and (not (digraph-forest-root-p forest n1))
 286                     (not (digraph-forest-root-p forest n2)))
 287           (aset merge-map n2 n1)
 288           (setq n1 (digraph-forest-node-id forest (aref parent-map n1))
 289                 n2 (digraph-forest-node-id forest (aref parent-map n2))))
 290         (if (digraph-forest-root-p forest n2)
 291             (aset merge-map n2 n1)
 292           (aset merge-map n1 n2)))))
 293   forest)
 294
 295 (defun digraph-forest-to-graph (forest)
 296   (let* ((merge-map (digraph-forest-merge-map forest))
 297          (parent-map (digraph-forest-parent-map forest))
 298          (old-len (length merge-map))
 299          (old-to-new (make-vector old-len nil))
 300          new-to-olds
 301          (new-len 0)
 302          (i 0)
 303          j
 304          graph
 305          )
 306     (while (< i old-len)
 307       (setq j (digraph-forest-node-id forest i))
 308       (if (aref old-to-new j)
 309           (aset old-to-new i (aref old-to-new j))
 310         (progn
 311           (aset old-to-new j new-len)
 312           (aset old-to-new i new-len)
 313           (setq new-len (1+ new-len))))
 314       (setq i (1+ i)))
 315     (setq new-to-olds (make-vector new-len nil)
 316           graph (make-vector new-len nil))
 317     (setq i (1- old-len))
 318     (while (<= 0 i)
 319       (setq j (aref old-to-new i))
 320       (aset new-to-olds j
 321             (cons i (aref new-to-olds j)))
 322       (setq i (1- i)))
 323     (setq i 0)
 324     (while (< i new-len)
 325       (setq j (aref parent-map (digraph-forest-node-id forest (car (aref new-to-olds i)))))
 326       (if (<= 0 j) (aset graph (aref old-to-new j)
 327                          (cons i (aref graph (aref old-to-new j)))))
 328       (setq i (1+ i)))
 329     (vector graph old-to-new new-to-olds)))
 330
 331 ;;; utilities
 332
 333 (defun digraph-list-uniq (il)
 334   (if (null il)
 335       ()
 336     (if (member (car il) (cdr il))
 337         (digraph-list-uniq (cdr il))
 338       (cons (car il) (digraph-list-uniq (cdr il))))))
 339
 340 '(
 341 (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)])
 342 [
 343  [(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]
 344  [14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 0]
 345  [(15) (14) (13) (12) (11) (10) (9) (8) (7) (6) (5) (4) (3) (2) (1) (0)]]
 346
 347 )