From a44fd054eb6c7485795aab748b849ca9da57aae3 Mon Sep 17 00:00:00 2001 From: akr Date: Tue, 9 Mar 1999 16:46:35 +0000 Subject: [PATCH] * digraph.el (digraph-saf-dfs): Use implicit control stack. --- ChangeLog | 4 +++ digraph.el | 87 ++++++++++++++++++++++++++++-------------------------------- 2 files changed, 44 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6dd5e1e..958ec0e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 1999-03-09 Tanaka Akira + * digraph.el (digraph-saf-dfs): Use implicit control stack. + +1999-03-09 Tanaka Akira + * digraph.el: Refined. * automata.el (automata): Adopted to above. diff --git a/digraph.el b/digraph.el index 2c80591..070886c 100644 --- a/digraph.el +++ b/digraph.el @@ -261,7 +261,8 @@ components in G as new nodes. (d-to-g (aref tmp 2)) (mm (digraph-make-merge-map (digraph-size d))) ) - (digraph-saf-dfs d mm '() (list (digraph-roots d))) + (digraph-saf-dfs d mm (make-vector (digraph-size d) 'unvisited) + nil (digraph-roots d)) (let* ((maps (digraph-mm-make-map mm)) (forward-map (car maps)) (reverse-map (cdr maps)) @@ -273,51 +274,43 @@ components in G as new nodes. (digraph-concat-forward-map g-to-d forward-map) (digraph-concat-reverse-map reverse-map d-to-g))))) -(defun digraph-saf-dfs (original mm node-stack descents-stack) - (let ((status (make-vector (digraph-size original) 'unvisited))) - (while descents-stack - (if (null (car descents-stack)) - (progn - (when node-stack - (aset status (car node-stack) 'visited) - (setq node-stack (cdr node-stack))) - (setq descents-stack (cdr descents-stack))) - (let ((node (caar descents-stack)) - (ascent (car node-stack))) - (setcar descents-stack (cdr (car descents-stack))) - (cond - ((eq (aref status node) 'visiting) - (error "not DAG")) - ((eq (aref status node) 'unvisited) - (digraph-mm-push-info mm node ascent) - (aset status node 'visiting) - (setq node-stack (cons node node-stack) - descents-stack (cons (digraph-descents original node) descents-stack))) - ((eq (aref status node) 'visited) - (let ((n node)) - (while (and n (eq (aref status (setq n (digraph-mm-canonicalize-node mm n))) 'visited)) - (setq n (digraph-mm-top-info mm n))) - (when n - (setq n (digraph-mm-canonicalize-node mm n))) - (let ((a (digraph-mm-canonicalize-node mm ascent)) - (b (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm node)))) - (while (and (not (eq a n)) (not (eq b n))) - (let ((a1 (digraph-mm-top-info mm a)) - (b1 (digraph-mm-top-info mm b))) - (digraph-mm-merge-node mm a b) - (unless a1 - (digraph-mm-push-info mm a b1)) - (setq a (and a1 (digraph-mm-canonicalize-node mm a1)) - b (and b1 (digraph-mm-canonicalize-node mm b1))))) - (when (and n (not (and (eq a n) (eq b n)))) - (if (eq a n) - (while (not (eq n b)) - (let ((b1 (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm b)))) - (digraph-mm-merge-node mm n b) - (setq b b1))) - (while (not (eq n a)) - (let ((a1 (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm a)))) - (digraph-mm-merge-node mm n a) - (setq a a1)))))))))))))) +(defun digraph-saf-dfs (d mm status ascent descents) + (while descents + (let ((node (car descents))) + (setq descents (cdr descents)) + (cond + ((eq (aref status node) 'visiting) + (error "not DAG")) + ((eq (aref status node) 'unvisited) + (digraph-mm-push-info mm node ascent) + (aset status node 'visiting) + (digraph-saf-dfs d mm status node (digraph-descents d node)) + (aset status node 'visited)) + ((eq (aref status node) 'visited) + (let ((n node)) + (while (and n (eq (aref status (setq n (digraph-mm-canonicalize-node mm n))) 'visited)) + (setq n (digraph-mm-top-info mm n))) + (when n + (setq n (digraph-mm-canonicalize-node mm n))) + (let ((a (digraph-mm-canonicalize-node mm ascent)) + (b (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm node)))) + (while (and (not (eq a n)) (not (eq b n))) + (let ((a1 (digraph-mm-top-info mm a)) + (b1 (digraph-mm-top-info mm b))) + (digraph-mm-merge-node mm a b) + (unless a1 + (digraph-mm-push-info mm a b1)) + (setq a (and a1 (digraph-mm-canonicalize-node mm a1)) + b (and b1 (digraph-mm-canonicalize-node mm b1))))) + (when (and n (not (and (eq a n) (eq b n)))) + (if (eq a n) + (while (not (eq n b)) + (let ((b1 (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm b)))) + (digraph-mm-merge-node mm n b) + (setq b b1))) + (while (not (eq n a)) + (let ((a1 (digraph-mm-canonicalize-node mm (digraph-mm-top-info mm a)))) + (digraph-mm-merge-node mm n a) + (setq a a1)))))))))))) (provide 'digraph) -- 1.7.10.4