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

55
dfs.scm
View File

@ -80,28 +80,44 @@
;;; ===================
;;;
;;; (dfs dag) ---> sorted-dag
;;; (dfs dag auto-leafs?) ---> sorted-dag
;;; (dfs dag pred auto-leafs? create-leaf) ---> sorted-dag
;;;
;;; 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))