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

written new, no need for set! any longer

This commit is contained in:
jottbee 2005-04-11 19:47:05 +00:00
parent 0257dc23a1
commit 2b8a9709a6
1 changed files with 95 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
dfs.scm
View File

@ -23,8 +23,6 @@
(cons item ls)
(cons (car ls) (insert pred item (cdr ls)))))
(define time 0)
(define-enumerated-type color :color
is-color?
the-colors
@ -70,11 +68,29 @@
(define (dfs->list dfs-node)
(list (dfs-name dfs-node) (dfs-adjacencies dfs-node) (dfs-ignored dfs-node)))
(define (dfs-lookup-node pred node-name dag)
(define (resolve-adj pred adj dag)
(find (lambda (candidate)
(pred (dfs-name candidate) node-name))
(pred (dfs-name candidate) adj))
dag))
(define (replace-node dag old new)
(let ((new-dag (delete old dag)))
(cons new new-dag)))
(define (paint-node node color)
(let ((name (dfs-name node))
(adjs (dfs-adjacencies node))
(time (dfs-ftime node))
(ignored (dfs-ignored node)))
(really-make-dfs name adjs color time ignored)))
(define (set-ftime node ftime)
(let ((name (dfs-name node))
(adjs (dfs-adjacencies node))
(color (dfs-color node))
(ignored (dfs-ignored node)))
(really-make-dfs name adjs color ftime ignored)))
;;;
;;; DEPTH FIRST SEARCH:
;;; ===================
@ -111,75 +127,82 @@
;;; sorted-dag : the sorted dag
;;;
(define (dfs dag . maybe-args)
(let-optionals maybe-args ((pred string=?)
(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))
;; (sort pred todo-list done-list)
(sort (lambda (current position)
(< (dfs-ftime current) (dfs-ftime position)))
;;
;; the result of this should be the dag with the ftimes
;;
(let for-all-nodes ((node-name (car node-names))
(nodes-to-do (cdr node-names))
(current-dag 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
pred auto-leafs? create-leaf)))
(if (not (null? nodes-to-do))
(for-all-nodes (car nodes-to-do)
(cdr nodes-to-do)
new-dag)
new-dag)))
(else (if (not (null? nodes-to-do))
(for-all-nodes (car nodes-to-do)
(cdr nodes-to-do)
current-dag)
current-dag)))))
'())
node-names))))
(create-leaf (lambda (unresolved-adj)
(make-dfs unresolved-adj '() #f))))
(let ((ftime<? (lambda (cur pos)
(< (dfs-ftime cur) (dfs-ftime pos)))))
(if (not (null? dag))
(sort ftime<?
(visit-all-nodes dag pred auto-leafs? create-leaf)
(list))
dag))))
(define (dfs-visit dag node pred auto-leafs? create-leaf)
;; (dfs-dag-show dag node)
(let ((name (dfs-name node))
(define (visit-all-nodes start-dag pred auto-leafs? create-leaf)
(let for-each-node ((node (car start-dag))
(todo (cdr start-dag))
(dag start-dag)
(time 0))
(cond
((eq? (dfs-color node) (color white))
(let* ((result (visit dag node time pred auto-leafs? create-leaf))
(new-dag (car result))
(new-time (cdr result)))
(if (not (null? todo))
(for-each-node (car todo) (cdr todo) new-dag new-time)
new-dag)))
((eq? (dfs-color node) (color black))
(if (not (null? todo))
(for-each-node (car todo) (cdr todo) dag time)
dag))
(else (error "visit-all-nodes: no match")))))
(define (finish-visit dag node time)
(let* ((new-time (+ 1 time))
(done-node (set-ftime (paint-node node (color black))
new-time))
(done-dag (replace-node dag node done-node)))
(cons done-dag new-time)))
(define (visit old-dag old-node time pred auto-leafs? create-leaf)
(let* ((node (paint-node old-node (color grey)))
(adjs (dfs-adjacencies node))
(ignored (dfs-ignored node)))
(let* ((current-node (really-make-dfs name adjs (color grey)
(dfs-ftime node) ignored))
(current-dag (cons current-node (delete node dag))))
(dag (replace-node old-dag old-node node)))
(if (not (null? adjs))
(let for-all-adjs ((current-adj (car adjs))
(todo-adjs (cdr adjs)))
(let ((maybe-node (dfs-lookup-node pred current-adj current-dag)))
(visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
(finish-visit dag node time))))
(define (visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
(let for-each-adj ((cur-adj (car adjs))
(todo (cdr adjs))
(cur-dag dag)
(cur-time time))
(let* ((res (follow-adj cur-dag node cur-adj cur-time
pred auto-leafs? create-leaf))
(new-dag (car res))
(new-time (cdr res)))
(if (not (null? todo))
(for-each-adj (car todo) (cdr todo) new-dag new-time)
(finish-visit new-dag node new-time)))))
(define (follow-adj dag node adj time pred auto-leafs? create-leaf)
(let ((maybe-node (resolve-adj pred adj dag)))
(if maybe-node
(begin
(if (eq? (dfs-color maybe-node) (color white))
(let ((next-dag (dfs-visit current-dag maybe-node
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)))))
(cond
((eq? (dfs-color maybe-node) (color white))
(visit dag maybe-node time pred auto-leafs? create-leaf))
((eq? (dfs-color maybe-node) (color grey))
(error "follow-adj, cycle detected: " (dfs-name node)))
((eq? (dfs-color maybe-node) (color black))
(cons dag time))
(else (error "follow-adj: no match")))
(if auto-leafs?
(let ((leaf (create-leaf current-adj)))
(set! current-dag (dfs-visit (cons leaf current-dag) leaf
pred auto-leafs? create-leaf)))
(error "dfs-visit: unresolveable adjacency: "
current-adj))))
(if (not (null? todo-adjs))
(for-all-adjs (car todo-adjs) (cdr todo-adjs)))))
(set! time (+ time 1))
(cons (really-make-dfs name adjs (color black) time ignored)
(delete current-node current-dag)))))
(let* ((leaf (create-leaf adj))
(new-dag (cons leaf dag)))
(visit new-dag leaf time pred auto-leafs? create-leaf))
(error "follow-adj: unresolveable adjacency: " adj)))))
(define (dfs-dag-show dag . maybe-arg)
(let-optionals maybe-arg ((node (make-dfs "show dag" '() #f)))