From 915cde7891e3dbcab0e6a10d07f496f9058f2ae1 Mon Sep 17 00:00:00 2001
From: jottbee <jottbee>
Date: Wed, 16 Feb 2005 14:07:41 +0000
Subject: [PATCH] dfs uses the create-leaf function to insert an unresolveable
 adjacency as a leaf (= new node) now. this function can be specified as an
 argument to dfs.

---
 dfs.scm | 57 ++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 36 insertions(+), 21 deletions(-)

diff --git a/dfs.scm b/dfs.scm
index be06d96..66c39fe 100644
--- a/dfs.scm
+++ b/dfs.scm
@@ -80,28 +80,44 @@
 ;;; ===================
 ;;; 
 ;;; (dfs dag) ---> sorted-dag
-;;; (dfs dag auto-leafs?) ---> sorted-dag
+;;; (dfs dag pred auto-leafs? create-leaf) ---> sorted-dag
 ;;; 
-;;; where 
+;;;             where 
 ;;; 
 ;;; dag           : '(#{:dfs} ...) ; representation of a given
 ;;;                                  directed acyclic graph) 
+;;; pred          : (pred adj-id node-id) ---> #t (if adj-identifier
+;;;                 and node-identifier are equal) or #f
+;;; 
 ;;; auto-leafs?   : #t (by default) or #f
+;;; 		    if auto-leafs? is set to #f then it is an error
+;;; 		    that an adjacency is unresolveable in the list of
+;;; 		    all node-names.  if auto-leafs? is enabled then
+;;; 		    every adjacency which is unresolveable in the list
+;;; 		    of all node-names is assumed to point to a leaf.
+;;; 		    this leaf is then created automatically by
+;;; 		    executing the function create-leaf. 
+;;; 
+;;; create-leaf   : (create-leaf unresolved-adjacency-identifier) ---> #{:dfs}
+;;; 		    create-leaf is a function which is called with the
+;;; 		    unresolved adjacency identifier. By default, this
+;;; 		    argument is function returning a leaf named with
+;;; 		    the unresolved adjacency identifier, with no
+;;; 		    adjacencies, and ignored-data set to #f. This
+;;;                 leaf, created by create-leaf, doesn't really have
+;;;                 to be a leaf; it can be a node as well. Maybe this
+;;;                 introduces new cyclic dependency problems; not sure.
+;;; 
 ;;; sorted-dag    : the sorted dag
 ;;; 
-;;; auto-leafs?:
-;;; 
-;;; if auto-leafs? is enabled then every adjacency which is unresolveable 
-;;; in the set of all node-names is assumed to point to a leaf.
-;;; this leaf is then created automatically: it consists of the node-name 
-;;; which was given by the initiating adjencency, the empty adjacencies 
-;;; list, and the ignored-data-field set to #f.
-;;; if auto-leafs? is set to #f then it is an error that an adjacency is 
-;;; unresolveable in the list of all node-names.
-;;; 
-(define (dfs dag . maybe-arg)
-  (let-optionals maybe-arg ((pred string=?)
-			    (auto-leafs? #t))
+(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))
@@ -118,7 +134,7 @@
 		    (cond 
 		     ((eq? (dfs-color current-node) (color white))
 		      (let ((new-dag (dfs-visit current-dag current-node 
-						pred auto-leafs?)))
+						pred auto-leafs? create-leaf)))
 			(if (not (null? nodes-to-do))
 			    (for-all-nodes (car nodes-to-do) 
 					   (cdr nodes-to-do) 
@@ -132,7 +148,7 @@
 		'())
 	  node-names))))
 
-(define (dfs-visit dag node pred auto-leafs?)
+(define (dfs-visit dag node pred auto-leafs? create-leaf)
   ;;  (dfs-dag-show dag node)
   (let ((name (dfs-name node))
 	(adjs (dfs-adjacencies node))
@@ -148,16 +164,15 @@
 		  (begin 
 		    (if (eq? (dfs-color maybe-node) (color white))
 			(let ((next-dag (dfs-visit current-dag maybe-node 
-						   pred auto-leafs?)))
+						   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 (really-make-dfs current-adj '() 
-						   (color white) 0 #f)))
+		      (let ((leaf (create-leaf current-adj)))
 			(set! current-dag (dfs-visit (cons leaf current-dag) leaf 
-						     pred auto-leafs?)))
+						     pred auto-leafs? create-leaf)))
 		      (error "dfs-visit: unresolveable adjacency: "
 			     current-adj))))
 	    (if (not (null? todo-adjs))