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

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.
This commit is contained in:
jottbee 2005-02-16 14:07:41 +00:00
parent 30d8807382
commit 915cde7891
1 changed files with 36 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
dfs.scm
View File

@ -80,28 +80,44 @@
;;; =================== ;;; ===================
;;; ;;;
;;; (dfs dag) ---> sorted-dag ;;; (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 ;;; dag : '(#{:dfs} ...) ; representation of a given
;;; directed acyclic graph) ;;; 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 ;;; 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 ;;; sorted-dag : the sorted dag
;;; ;;;
;;; auto-leafs?: (define (dfs dag . maybe-args)
;;; (let-optionals maybe-args ((pred string=?)
;;; if auto-leafs? is enabled then every adjacency which is unresolveable (auto-leafs? #t)
;;; in the set of all node-names is assumed to point to a leaf. (create-leaf (lambda (unresolved-adj-id)
;;; this leaf is then created automatically: it consists of the node-name ;; (display "unresolved adjecency: ")
;;; which was given by the initiating adjencency, the empty adjacencies ;; (display unresolved-adj-id)
;;; list, and the ignored-data-field set to #f. ;; (newline)
;;; if auto-leafs? is set to #f then it is an error that an adjacency is (make-dfs unresolved-adj-id '() #f))))
;;; unresolveable in the list of all node-names.
;;;
(define (dfs dag . maybe-arg)
(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))
@ -118,7 +134,7 @@
(cond (cond
((eq? (dfs-color current-node) (color white)) ((eq? (dfs-color current-node) (color white))
(let ((new-dag (dfs-visit current-dag current-node (let ((new-dag (dfs-visit current-dag current-node
pred auto-leafs?))) pred auto-leafs? create-leaf)))
(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)
@ -132,7 +148,7 @@
'()) '())
node-names)))) 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) ;; (dfs-dag-show dag node)
(let ((name (dfs-name node)) (let ((name (dfs-name node))
(adjs (dfs-adjacencies node)) (adjs (dfs-adjacencies node))
@ -148,16 +164,15 @@
(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 maybe-node (let ((next-dag (dfs-visit current-dag maybe-node
pred auto-leafs?))) pred auto-leafs? create-leaf)))
(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: "
(dfs-name node))))) (dfs-name node)))))
(if auto-leafs? (if auto-leafs?
(let ((leaf (really-make-dfs current-adj '() (let ((leaf (create-leaf current-adj)))
(color white) 0 #f)))
(set! current-dag (dfs-visit (cons leaf current-dag) leaf (set! current-dag (dfs-visit (cons leaf current-dag) leaf
pred auto-leafs?))) pred auto-leafs? create-leaf)))
(error "dfs-visit: unresolveable adjacency: " (error "dfs-visit: unresolveable adjacency: "
current-adj)))) current-adj))))
(if (not (null? todo-adjs)) (if (not (null? todo-adjs))