written new, no need for set! any longer
This commit is contained in:
jottbee
parent
0257dc23a1
commit
2b8a9709a6
167
dfs.scm
167
dfs.scm
|
|
@ -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=?)
|
||||
(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))))
|
||||
(let-optionals maybe-args
|
||||
((pred string=?)
|
||||
(auto-leafs? #t)
|
||||
(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))
|
||||
(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))))
|
||||
(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)))
|
||||
(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)))))
|
||||
(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)))))
|
||||
(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))
|
||||
(dag (replace-node old-dag old-node node)))
|
||||
(if (not (null? adjs))
|
||||
(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
|
||||
(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 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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue