suzanne.soy/profile
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix dropping cycles

Browse Source 
svn: r14811

original commit: ccca3b3df6d351ef6ee2f0158b8c7da4a3451b50
This commit is contained in:
Eli Barzilay 2009-05-14 15:08:56 +00:00
parent 8ad8b54bcc
commit 304cdc2483
1 changed files with 2 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/profile/utils.ss
View File

@ -64,8 +64,9 @@
;; remove visited and duplicates
[next (remove-duplicates (remq* sorted next))]
;; leave only nodes with no other incoming edges
[seen (append next sorted)] ; important for cycles
[next* (filter (lambda (node)
(andmap (lambda (e) (memq (edge-caller e) sorted))
(andmap (lambda (e) (memq (edge-caller e) seen))
(node-callers node)))
next)]
;; but if all nodes have other incoming edges, then there must be
@ -74,32 +75,3 @@
;; apply sublevel
[next (if sublevel (sublevel next) next)])
(loop next (append (reverse next) sorted))))))
#|
(define-syntax-rule (letnodes [id ...] body ...)
(let ([id (make-node 'id #f '() 0 0 '() '())] ...) body ...))
(define (X . -> . Y)
(let ([e (make-edge 0 X 0 Y 0)])
(set-node-callers! Y (cons e (node-callers Y)))
(set-node-callees! X (cons e (node-callees X)))))
(letnodes [A B C]
(A . -> . B)
(B . -> . C)
(equal? (topological-sort A values)
(list A B C)))
(letnodes [A B C]
;; check that a cycle doesn't lead to dropping nodes
(A . -> . B)
(A . -> . C)
(B . -> . A)
(B . -> . C)
(C . -> . A)
(C . -> . B)
(null? (remq* (topological-sort A values) (list A B C))))
(letnodes [A B C D]
(A . -> . B)
(B . -> . C)
(C . -> . D)
(A . -> . D)
(equal? (topological-sort A values)
(list A B C D)))
|#