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