scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

a pred function to compare a given adjacency-identifier with a given 

target-identifiers can now be specified as optarg #1. auto-leafs? is
optarg #2 now.
This commit is contained in:
jottbee 2005-02-16 11:05:39 +00:00
parent 12aa087ddf
commit 30d8807382
1 changed files with 13 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
dfs.scm
View File

@ -70,9 +70,9 @@
(define (dfs->list dfs-node)
(list (dfs-name dfs-node) (dfs-adjacencies dfs-node) (dfs-ignored dfs-node)))
(define (dfs-lookup-node node-name dag)
(define (dfs-lookup-node pred node-name dag)
(find (lambda (candidate)
(string=? (dfs-name candidate) node-name))
(pred (dfs-name candidate) node-name))
dag))
;;;
@ -100,7 +100,8 @@
;;; unresolveable in the list of all node-names.
;;;
(define (dfs dag . maybe-arg)
(let-optionals maybe-arg ((auto-leafs? #t))
(let-optionals maybe-arg ((pred string=?)
(auto-leafs? #t))
(set! time 0)
(let ((node-names (map dfs-name dag)))
(if (not (null? node-names))
@ -113,11 +114,11 @@
(let for-all-nodes ((node-name (car node-names))
(nodes-to-do (cdr node-names))
(current-dag dag))
(let ((current-node (dfs-lookup-node node-name current-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 auto-leafs?)))
(let ((new-dag (dfs-visit current-dag current-node
pred auto-leafs?)))
(if (not (null? nodes-to-do))
(for-all-nodes (car nodes-to-do)
(cdr nodes-to-do)
@ -131,7 +132,7 @@
'())
node-names))))
(define (dfs-visit dag node auto-leafs?)
(define (dfs-visit dag node pred auto-leafs?)
;; (dfs-dag-show dag node)
(let ((name (dfs-name node))
(adjs (dfs-adjacencies node))
@ -142,12 +143,12 @@
(if (not (null? adjs))
(let for-all-adjs ((current-adj (car adjs))
(todo-adjs (cdr adjs)))
(let ((maybe-node (dfs-lookup-node current-adj current-dag)))
(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 auto-leafs?)))
(let ((next-dag (dfs-visit current-dag maybe-node
pred auto-leafs?)))
(set! current-dag next-dag))
(if (eq? (dfs-color maybe-node) (color grey))
(error "dfs-visit: cycle detected; node-name: "
@ -155,8 +156,8 @@
(if auto-leafs?
(let ((leaf (really-make-dfs current-adj '()
(color white) 0 #f)))
(set! current-dag (dfs-visit (cons leaf current-dag)
leaf auto-leafs?)))
(set! current-dag (dfs-visit (cons leaf current-dag) leaf
pred auto-leafs?)))
(error "dfs-visit: unresolveable adjacency: "
current-adj))))
(if (not (null? todo-adjs))