digraph.el

   1 ;;; directed graph package.
   2
   3 (defun digraph-make (&optional size)
   4   "Return newly allocated graph.
   5 If SIZE is nil, it is assumed to 0."
   6   (unless size (setq size 0))
   7   (cons size (make-vector (max 1 size) nil)))
   8
   9 (defalias 'digraph-size 'car)
  10
  11 (defun digraph-new-node (g)
  12   "Allocate new node in G and return it."
  13   (unless (< (digraph-size g) (length (cdr g)))
  14     (setcdr g (vconcat (cdr g) (make-vector (length (cdr g)) nil))))
  15   (prog1
  16       (digraph-size g)
  17     (setcar g (1+ (digraph-size g)))))
  18
  19 (defun digraph-add-edge (g n1 n2)
  20   "Make edge from N1 to N2 in G."
  21   (unless (memq n2 (aref (cdr g) n1))
  22     (aset (cdr g) n1 (cons n2 (aref (cdr g) n1)))))
  23
  24 (defun digraph-descents (g n1)
  25   "Return nodes that has edge from N1 in G."
  26   (aref (cdr g) n1))
  27
  28 (put 'digraph-forall-node 'lisp-indent-function 2)
  29 (defmacro digraph-forall-node (g-exp n-var &rest body)
  30   (let ((g (make-symbol "g"))
  31         (size (make-symbol "size")))
  32     `(let* ((,g ,g-exp)
  33             (,n-var 0)
  34             (,size (digraph-size ,g)))
  35        (while (< ,n-var ,size)
  36          (progn
  37            ,@body)
  38          (setq ,n-var (1+ ,n-var))))))
  39
  40 (put 'digraph-forall-edge 'lisp-indent-function 3)
  41 (defmacro digraph-forall-edge (g-exp i-var j-var &rest body)
  42   (let ((g (make-symbol "g"))
  43         (tmp (make-symbol "tmp"))
  44         (size (make-symbol "size")))
  45     `(let* ((,g ,g-exp)
  46             (,size (digraph-size ,g))
  47             (,i-var 0)
  48             ,j-var ,tmp)
  49        (while (< ,i-var ,size)
  50          (setq ,tmp (aref (cdr ,g) ,i-var))
  51          (while ,tmp
  52            (setq ,j-var (car ,tmp))
  53            (progn
  54              ,@body)
  55            (setq ,tmp (cdr ,tmp)))
  56          (setq ,i-var (1+ ,i-var))))))
  57
  58 (defun digraph-reverse (g)
  59   "Return newly allocated graph with reversed edge."
  60   (let* ((len (digraph-size g))
  61          (a (cdr g))
  62          (rev (make-vector len nil))
  63          (i 0))
  64     (while (< i len)
  65       (let ((links (aref a i)))
  66         (while links
  67           (if (not (member i (aref rev (car links))))
  68               (aset rev (car links) (cons i (aref rev (car links)))))
  69           (setq links (cdr links))))
  70       (setq i (1+ i)))
  71     (cons len rev)))
  72
  73 (defun digraph-leaves (g)
  74   "Return list of leaves of G."
  75   (let* ((i (digraph-size g))
  76          (a (cdr g))
  77          (res ()))
  78     (while (< 0 i)
  79       (setq i (1- i))
  80       (if (null (aref a i))
  81           (setq res (cons i res))))
  82     res))
  83
  84 (defun digraph-roots (g)
  85   "Return list of roots of G."
  86   (digraph-leaves (digraph-reverse g)))
  87
  88 ;;; topological sort
  89
  90 (defun digraph-tsort (g)
  91   "Sort nodes in a graph toporogicaly.
  92
  93 G is a graph and
  94 result of digraph-tsort is list of lists of nodes.
  95
  96 If (nth n result) contains an node i, it represents the fact as
  97 follows.
  98
  99 1. For all j in (nth n result) and j != i, node i depends to node j
 100 and vice versa.
 101
 102 2. For all m < n and j in (nth m result), node i does not depend
 103 to node j."
 104   (let* ((len (digraph-size g))
 105          (ord (make-vector len nil))
 106          (i 0)
 107          (res ()))
 108     (while (< i len)
 109       (if (not (aref ord i))
 110           (setq res (nth 3 (digraph-tsort-dfs (cdr g) len ord i 0 () res))))
 111       (setq i (1+ i)))
 112     res))
 113
 114 (defun digraph-tsort-dfs (dep len ord i id stk res)
 115   (aset ord i id)
 116   (let ((js (aref dep i))
 117         (m id)
 118         (nid (1+ id))
 119         (stk (cons i stk))
 120         (res res))
 121     (while js
 122       (let* ((j (car js)) (jo (aref ord j)))
 123         (if jo
 124             (setq m (if (< m jo) m jo))
 125           (let* ((tmp (digraph-tsort-dfs dep len ord j nid stk res))
 126                  (m0 (nth 0 tmp)))
 127             (setq m (if (< m m0) m m0)
 128                   nid (nth 1 tmp)
 129                   stk (nth 2 tmp)
 130                   res (nth 3 tmp)))))
 131       (setq js (cdr js)))
 132     (if (= m id)
 133         (let* ((p (member i stk))
 134                (nstk (cdr p))
 135                (tmp stk))
 136           (setcdr p ())
 137           (while tmp
 138             (aset ord (car tmp) len)
 139             (setq tmp (cdr tmp)))
 140           (list m nid nstk (cons stk res)))
 141       (list m nid stk res))))
 142
 143 ;;; merge map
 144
 145 (defun digraph-make-merge-map (size)
 146   (make-vector size nil))
 147
 148 (defun digraph-mm-canonical-node-p (mm n)
 149   (not (integerp (aref mm n))))
 150
 151 (defun digraph-mm-canonicalize-node (mm n)
 152   (while (not (digraph-mm-canonical-node-p mm n))
 153     (setq n (aref mm n)))
 154   n)
 155
 156 (defun digraph-mm-push-info (mm n info)
 157   "Push additional information for N in MM."
 158   (setq n (digraph-mm-canonicalize-node mm n))
 159   (aset mm n (cons info (aref mm n))))
 160
 161 (defun digraph-mm-top-info (mm n)
 162   "Get a top information for N in MM."
 163   (setq n (digraph-mm-canonicalize-node mm n))
 164   (car (aref mm n)))
 165
 166 (defun digraph-mm-pop-info (mm n)
 167   "Pop an information for N in MM."
 168   (setq n (digraph-mm-canonicalize-node mm n))
 169   (aset mm n (cdr (aref mm n))))
 170
 171 (defun digraph-mm-merge-node (mm n m)
 172   "Merge N and M in MM.
 173 The information for N is used for merged node."
 174   (setq n (digraph-mm-canonicalize-node mm n))
 175   (setq m (digraph-mm-canonicalize-node mm m))
 176   (unless (= n m)
 177     (aset mm m n)))
 178
 179 (defun digraph-mm-make-map (mm)
 180   (let ((i 0) (f-size (length mm)) (t-size 0))
 181     (while (< i f-size)
 182       (when (digraph-mm-canonical-node-p mm i)
 183         (digraph-mm-push-info mm i t-size)
 184         (setq t-size (1+ t-size)))
 185       (setq i (1+ i)))
 186     (let ((forward-map (make-vector f-size ()))
 187           (reverse-map (make-vector t-size ()))
 188           j)
 189       (setq i (1- f-size))
 190       (while (<= 0 i)
 191         (setq j (digraph-mm-top-info mm i))
 192         (aset forward-map i j)
 193         (aset reverse-map j (cons i (aref reverse-map j)))
 194         (setq i (1- i)))
 195       (setq i 0)
 196       (while (< i f-size)
 197         (when (digraph-mm-canonical-node-p mm i)
 198           (digraph-mm-pop-info mm i))
 199         (setq i (1+ i)))
 200       (cons forward-map reverse-map))))
 201
 202 (defun digraph-concat-forward-map (map &rest maps)
 203   (while maps
 204     (setq map (vconcat (mapcar (lambda (n) (aref (car maps) n)) map))
 205           maps (cdr maps)))
 206   map)
 207
 208 (defun digraph-concat-reverse-map (map &rest maps)
 209   (while maps
 210     (setq map
 211           (vconcat
 212            (mapcar
 213             (lambda (elts)
 214               (apply
 215                'append
 216                (mapcar (lambda (e) (aref (car maps) e)) elts)))
 217             map))
 218           maps (cdr maps)))
 219   map)
 220
 221 ;; split
 222
 223 (defun digraph-split-as-dag (g)
 224   "Returns 3 element vector of follows.
 225
 226 0. Directed acyclic graph generated by mergeing each strongly connected
 227 components in G as new nodes.
 228
 229 1. Map from a node in g to a node in result.
 230
 231 2. Map from a node in result to nodes in g."
 232   (let* ((tmp (digraph-tsort g))
 233          (mm (digraph-make-merge-map (digraph-size g))))
 234     (while tmp
 235       (let ((n (caar tmp))
 236             (nodes (cdar tmp)))
 237         (while nodes
 238           (digraph-mm-merge-node mm n (car nodes))
 239           (setq nodes (cdr nodes))))
 240       (setq tmp (cdr tmp)))
 241     (let* ((maps (digraph-mm-make-map mm))
 242            (forward-map (car maps))
 243            (reverse-map (cdr maps))
 244            (new-g (digraph-make (length reverse-map))))
 245       (digraph-forall-edge g i j
 246         (unless (= (aref forward-map i) (aref forward-map j))
 247           (digraph-add-edge new-g (aref forward-map i) (aref forward-map j))))
 248       (vector new-g forward-map reverse-map))))
 249
 250 (defun digraph-split-as-forest (g)
 251   "Returns 3 element vector of follows.
 252
 253 0. Tree generated by merging nodes which have common descent node.
 254
 255 1. Map from a node in g to a node in result.
 256
 257 2. Map from a node in result to nodes in g."
 258   (let* ((tmp (digraph-split-as-dag g))
 259          (d (aref tmp 0))
 260          (g-to-d (aref tmp 1))
 261          (d-to-g (aref tmp 2))
 262          (mm (digraph-make-merge-map (digraph-size d)))
 263          )
 264     (digraph-saf-dfs d mm (make-vector (digraph-size d) 'unvisited)
 265                      nil (digraph-roots d))
 266     (let* ((maps (digraph-mm-make-map mm))
 267            (forward-map (car maps))
 268            (reverse-map (cdr maps))
 269            (f (digraph-make (length reverse-map))))
 270       (digraph-forall-edge d i j
 271         (unless (= (aref forward-map i) (aref forward-map j))
 272           (digraph-add-edge f (aref forward-map i) (aref forward-map j))))
 273       (vector f
 274               (digraph-concat-forward-map g-to-d forward-map)
 275               (digraph-concat-reverse-map reverse-map d-to-g)))))
 276
 277 (defun digraph-saf-dfs (d mm status ascent descents)
 278   (while descents
 279     (let ((node (car descents)))
 280       (setq descents (cdr descents))
 281       (cond
 282        ((eq (aref status node) 'visiting)
 283         (error "not DAG"))
 284        ((eq (aref status node) 'unvisited)
 285         (digraph-mm-push-info mm node ascent)
 286         (aset status node 'visiting)
 287         (digraph-saf-dfs d mm status node (digraph-descents d node))
 288         (aset status node 'visited))
 289        ((eq (aref status node) 'visited)
 290         (let ((n node))
 291           (while (and n (eq (aref status (setq n (digraph-mm-canonicalize-node mm n))) 'visited))
 292             (setq n (digraph-mm-top-info mm n)))
 293           (when n
 294             (setq n (digraph-mm-canonicalize-node mm n)))
 295           (let ((a (digraph-mm-canonicalize-node mm ascent))
 296                 (b (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm node))))
 297             (while (and (not (eq a n)) (not (eq b n)))
 298               (let ((a1 (digraph-mm-top-info mm a))
 299                     (b1 (digraph-mm-top-info mm b)))
 300                 (digraph-mm-merge-node mm a b)
 301                 (unless a1
 302                   (digraph-mm-push-info mm a b1))
 303                 (setq a (and a1 (digraph-mm-canonicalize-node mm a1))
 304                       b (and b1 (digraph-mm-canonicalize-node mm b1)))))
 305             (when (and n (not (and (eq a n) (eq b n))))
 306               (if (eq a n)
 307                   (while (not (eq n b))
 308                     (let ((b1 (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm b))))
 309                       (digraph-mm-merge-node mm n b)
 310                       (setq b b1)))
 311                 (while (not (eq n a))
 312                   (let ((a1 (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm a))))
 313                     (digraph-mm-merge-node mm n a)
 314                     (setq a a1))))))))))))
 315
 316 (provide 'digraph)