From 2b8a9709a6ca8db1db9782958bea87dbfdc4c159 Mon Sep 17 00:00:00 2001
From: jottbee <jottbee>
Date: Mon, 11 Apr 2005 19:47:05 +0000
Subject: [PATCH] written new, no need for set! any longer

---
 dfs.scm | 167 ++++++++++++++++++++++++++++++++------------------------
 1 file changed, 95 insertions(+), 72 deletions(-)

diff --git a/dfs.scm b/dfs.scm
index d3216a9..5cdeb0a 100644
--- a/dfs.scm
+++ b/dfs.scm
@@ -23,8 +23,6 @@
       (cons item ls)
       (cons (car ls) (insert pred item (cdr ls)))))
 
-(define time 0)
-
 (define-enumerated-type color :color
   is-color?
   the-colors
@@ -70,11 +68,29 @@
 (define (dfs->list dfs-node)
   (list (dfs-name dfs-node) (dfs-adjacencies dfs-node) (dfs-ignored dfs-node)))
 
-(define (dfs-lookup-node pred node-name dag)
+(define (resolve-adj pred adj dag)
   (find (lambda (candidate) 
-	  (pred (dfs-name candidate) node-name))
+	  (pred (dfs-name candidate) adj))
 	dag))
 
+(define (replace-node dag old new)
+  (let ((new-dag (delete old dag)))
+    (cons new new-dag)))
+
+(define (paint-node node color)
+  (let ((name (dfs-name node))
+	(adjs (dfs-adjacencies node))
+	(time (dfs-ftime node))
+	(ignored (dfs-ignored node)))
+    (really-make-dfs name adjs color time ignored)))
+
+(define (set-ftime node ftime)
+  (let ((name (dfs-name node))
+	(adjs (dfs-adjacencies node))
+	(color (dfs-color node))
+	(ignored (dfs-ignored node)))
+    (really-make-dfs name adjs color ftime ignored)))
+
 ;;; 
 ;;; DEPTH FIRST SEARCH:
 ;;; ===================
@@ -111,75 +127,82 @@
 ;;; sorted-dag    : the sorted dag
 ;;; 
 (define (dfs dag . maybe-args)
-  (let-optionals maybe-args ((pred string=?)
-			     (auto-leafs? #t)
-			     (create-leaf (lambda (unresolved-adj-id) 
-					    ;; (display "unresolved adjecency: ")
-					    ;; (display unresolved-adj-id)
-					    ;; (newline)
-					    (make-dfs unresolved-adj-id '() #f))))
-    (set! time 0)
-    (let ((node-names (map dfs-name dag)))
-      (if (not (null? node-names))
-	  ;; (sort pred todo-list done-list)
-	  (sort (lambda (current position)
-		  (< (dfs-ftime current) (dfs-ftime position)))
-		;; 
-		;; the result of this should be the dag with the ftimes
-		;; 
-		(let for-all-nodes ((node-name (car node-names))
-				    (nodes-to-do (cdr node-names))
-				    (current-dag dag))
-		  (let ((current-node (dfs-lookup-node pred node-name current-dag)))
-		    (cond 
-		     ((eq? (dfs-color current-node) (color white))
-		      (let ((new-dag (dfs-visit current-dag current-node 
-						pred auto-leafs? create-leaf)))
-			(if (not (null? nodes-to-do))
-			    (for-all-nodes (car nodes-to-do) 
-					   (cdr nodes-to-do) 
-					   new-dag)
-			    new-dag)))
-		     (else (if (not (null? nodes-to-do))
-			       (for-all-nodes (car nodes-to-do) 
-					      (cdr nodes-to-do) 
-					      current-dag)
-			       current-dag)))))
-		'())
-	  node-names))))
+  (let-optionals maybe-args 
+      ((pred string=?)
+       (auto-leafs? #t)
+       (create-leaf (lambda (unresolved-adj) 
+		      (make-dfs unresolved-adj '() #f))))
+    (let ((ftime<? (lambda (cur pos)
+		     (< (dfs-ftime cur) (dfs-ftime pos)))))
+      (if (not (null? dag))
+	  (sort ftime<? 
+		(visit-all-nodes dag pred auto-leafs? create-leaf)
+		(list))
+	  dag))))
 
-(define (dfs-visit dag node pred auto-leafs? create-leaf)
-  ;;  (dfs-dag-show dag node)
-  (let ((name (dfs-name node))
-	(adjs (dfs-adjacencies node))
-	(ignored (dfs-ignored node)))
-    (let* ((current-node (really-make-dfs name adjs (color grey) 
-					  (dfs-ftime node) ignored))
-	   (current-dag (cons current-node (delete node dag))))
-      (if (not (null? adjs))
-	  (let for-all-adjs ((current-adj (car adjs))
-			     (todo-adjs (cdr adjs)))
-	    (let ((maybe-node (dfs-lookup-node pred current-adj current-dag)))
-	      (if maybe-node
-		  (begin 
-		    (if (eq? (dfs-color maybe-node) (color white))
-			(let ((next-dag (dfs-visit current-dag maybe-node 
-						   pred auto-leafs? create-leaf)))
-			  (set! current-dag next-dag))
-			(if (eq? (dfs-color maybe-node) (color grey))
-			    (error "dfs-visit: cycle detected; node-name: "
-				   (dfs-name node)))))
-		  (if auto-leafs? 
-		      (let ((leaf (create-leaf current-adj)))
-			(set! current-dag (dfs-visit (cons leaf current-dag) leaf 
-						     pred auto-leafs? create-leaf)))
-		      (error "dfs-visit: unresolveable adjacency: "
-			     current-adj))))
-	    (if (not (null? todo-adjs))
-		(for-all-adjs (car todo-adjs) (cdr todo-adjs)))))
-      (set! time (+ time 1))
-      (cons (really-make-dfs name adjs (color black) time ignored)
-	    (delete current-node current-dag)))))
+(define (visit-all-nodes start-dag pred auto-leafs? create-leaf)
+  (let for-each-node ((node (car start-dag))
+		      (todo (cdr start-dag))
+		      (dag start-dag)
+		      (time 0))
+    (cond 
+     ((eq? (dfs-color node) (color white))
+      (let* ((result (visit dag node time pred auto-leafs? create-leaf))
+	     (new-dag (car result))
+	     (new-time (cdr result)))
+	(if (not (null? todo))
+	    (for-each-node (car todo) (cdr todo) new-dag new-time)
+	    new-dag)))
+     ((eq? (dfs-color node) (color black))
+      (if (not (null? todo))
+	  (for-each-node (car todo) (cdr todo) dag time)
+	  dag))
+     (else (error "visit-all-nodes: no match")))))
+
+(define (finish-visit dag node time)
+  (let* ((new-time (+ 1 time))
+	 (done-node (set-ftime (paint-node node (color black))
+			       new-time))
+	 (done-dag (replace-node dag node done-node)))
+    (cons done-dag new-time)))
+
+(define (visit old-dag old-node time pred auto-leafs? create-leaf)
+  (let* ((node (paint-node old-node (color grey)))
+	 (adjs (dfs-adjacencies node))
+	 (dag (replace-node old-dag old-node node)))
+    (if (not (null? adjs))
+	(visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
+	(finish-visit dag node time))))
+
+(define (visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
+  (let for-each-adj ((cur-adj (car adjs))
+		     (todo (cdr adjs))
+		     (cur-dag dag)
+		     (cur-time time))
+    (let* ((res (follow-adj cur-dag node cur-adj cur-time 
+			    pred auto-leafs? create-leaf))
+	   (new-dag (car res))
+	   (new-time (cdr res)))
+      (if (not (null? todo))
+	  (for-each-adj (car todo) (cdr todo) new-dag new-time)
+	  (finish-visit new-dag node new-time)))))
+
+(define (follow-adj dag node adj time pred auto-leafs? create-leaf)
+  (let ((maybe-node (resolve-adj pred adj dag)))
+    (if maybe-node
+	(cond 
+	 ((eq? (dfs-color maybe-node) (color white))
+	  (visit dag maybe-node time pred auto-leafs? create-leaf))
+	 ((eq? (dfs-color maybe-node) (color grey))
+	  (error "follow-adj, cycle detected: " (dfs-name node)))
+	 ((eq? (dfs-color maybe-node) (color black))
+	  (cons dag time))
+	 (else (error "follow-adj: no match")))
+	(if auto-leafs? 
+	    (let* ((leaf (create-leaf adj))
+		   (new-dag (cons leaf dag)))
+	      (visit new-dag leaf time pred auto-leafs? create-leaf))
+	    (error "follow-adj: unresolveable adjacency: " adj)))))
 
 (define (dfs-dag-show dag . maybe-arg)
   (let-optionals maybe-arg ((node (make-dfs "show dag" '() #f)))