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

subsort is really any function to apply on a level

Browse Source 
svn: r14806

original commit: 0d933c3f86ec2f269fe166f66a9a91300d4e25ff
This commit is contained in:
Eli Barzilay 2009-05-14 07:47:28 +00:00
parent c0fe0ebac5
commit 0dc181a285
1 changed files with 7 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/profile/utils.ss
View File

@ -49,10 +49,12 @@
[else (filter hide? (profile-nodes profile))])) [else (filter hide? (profile-nodes profile))]))
;; A simple topological sort of nodes using BFS, starting from node `x' (which ;; A simple topological sort of nodes using BFS, starting from node `x' (which
;; will be given as the special *-node). `subsort' is a `resolver' function to ;; will be given as the special *-node). `sublevel' is a function that is
;; sort nodes on the same level. ;; applied on each set of nodes at the same level in turn; can be used as a
;; `resolver' function to sort nodes on the same level, or to get a graphical
;; layout.
(provide topological-sort) (provide topological-sort)
(define (topological-sort x subsort) (define (topological-sort x [sublevel #f])
(let loop ([todo (list x)] [sorted (list x)]) (let loop ([todo (list x)] [sorted (list x)])
(if (null? todo) (if (null? todo)
(reverse sorted) (reverse sorted)
@ -69,8 +71,8 @@
;; but if all nodes have other incoming edges, then there must be ;; but if all nodes have other incoming edges, then there must be
;; a cycle, so just do them now (instead of dropping them) ;; a cycle, so just do them now (instead of dropping them)
[next (if (and (null? next*) (pair? next)) next next*)] [next (if (and (null? next*) (pair? next)) next next*)]
;; sort using subsort ;; apply sublevel
[next (subsort next)]) [next (if sublevel (sublevel next) next)])
(loop next (append (reverse next) sorted)))))) (loop next (append (reverse next) sorted))))))
#| #|
(define-syntax-rule (letnodes [id ...] body ...) (define-syntax-rule (letnodes [id ...] body ...)