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

better layout for topological-sort

Browse Source 
svn: r14834

original commit: 27e4c708c791a732f9c5fe016159c450ed3605f2
This commit is contained in:
Eli Barzilay 2009-05-15 19:16:56 +00:00
parent 19bb120207
commit 2ac42691a8
3 changed files with 67 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/profile/analyzer.ss
View File

@ -78,10 +78,10 @@
(set-node-total! *-node total-time)
;; convert the nodes from the hash to a list, do a topological sort, and then
;; sort by total time (combining both guarantees(?) sensible order)
(let ([nodes (remq *-node (topological-sort
*-node
(lambda (nodes)
(sort nodes > #:key node-total))))])
(let* ([nodes (topological-sort *-node)]
[nodes (append-map (lambda (nodes) (sort nodes > #:key node-total))
nodes)]
[nodes (remq *-node nodes)])
;; sort all the edges in the nodes according to total time
(for ([n (in-list nodes)])
(set-node-callees! n (sort (node-callees n) > #:key edge-callee-time))

48
collects/profile/utils.ss
View File

@ -48,30 +48,26 @@
[(zero? total-time) (profile-nodes profile)]
[else (filter hide? (profile-nodes profile))]))
;; A simple topological sort of nodes using BFS, starting from node `x' (which
;; will be given as the special *-node). `sublevel' is a function that is
;; 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.
;; A simple topological sort of nodes using the Khan method, starting
;; from node `x' (which will be given as the special *-node). The
;; result is a list of node lists, each one corresponds to one level.
(provide topological-sort)
(define (topological-sort x [sublevel #f])
(let loop ([todo (list x)] [sorted (list x)])
(if (null? todo)
(reverse sorted)
(let* (;; take the next level of nodes
[next (append-map (lambda (x) (map edge-callee (node-callees x)))
todo)]
;; 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) seen))
(node-callers node)))
next)]
;; but if all nodes have other incoming edges, then there must be
;; a cycle, so just do them now (instead of dropping them)
[next (if (and (null? next*) (pair? next)) next next*)]
;; apply sublevel
[next (if sublevel (sublevel next) next)])
(loop next (append (reverse next) sorted))))))
(define (topological-sort x)
(let loop ([todo (list x)] [sorted (list (list x))] [seen (list x)])
(let* (;; take the next level of nodes
[next (append-map (lambda (x) (map edge-callee (node-callees x)))
todo)]
;; remove visited and duplicates
[next (remove-duplicates (remq* seen next))]
;; leave only nodes with no other incoming edges
[seen* (append next seen)] ; important for cycles
[next* (filter (lambda (node)
(andmap (lambda (e) (memq (edge-caller e) seen*))
(node-callers node)))
next)]
;; but if all nodes have other incoming edges, then there must be a
;; cycle, so just do them now (instead of dropping them)
[next (if (null? next*) next next*)])
(if (null? next)
(reverse sorted)
(loop next (cons next sorted) (append next seen))))))

77
collects/tests/profile/topsort.ss
View File

@ -1,52 +1,57 @@
#lang scheme/base
(require tests/eli-tester profile/structs profile/utils)
(require tests/eli-tester profile/structs profile/utils
scheme/list scheme/match)
(define (connect! from to)
(define e (make-edge 0 from 0 to 0))
(set-node-callers! to (cons e (node-callers to )))
(set-node-callees! from (cons e (node-callees from))))
(define edge (make-edge 0 from 0 to 0))
(set-node-callers! to (cons edge (node-callers to )))
(set-node-callees! from (cons edge (node-callees from))))
(define-syntax with-graph
(syntax-rules (->)
[(_ [] <from> -> <to> -> more ...)
(begin (connect! <from> <to>) (with-graph [] <to> -> more ...))]
[(_ [] <from> -> <to> more ...)
(begin (connect! <from> <to>) (with-graph [] more ...))]
[(_ [] more ...) (begin more ...)]
[(_ [<id> ...] more ...)
(let ([<id> (make-node '<id> #f '() 0 0 '() '())] ...)
(with-graph [] more ...))]))
(define (sort-graph . edges)
(define names (remove-duplicates (remq* '(->) (append* edges))))
(define nodes (map (lambda (sym) (make-node sym #f '() 0 0 '() '())) names))
(define ->node (make-immutable-hasheq (map cons names nodes)))
(for ([edges edges])
(let loop ([xs edges])
(match xs
[(list from '-> to '-> _ ...)
(connect! (hash-ref ->node from) (hash-ref ->node to))
(loop (cddr xs))]
[(list from '-> to _ ...)
(connect! (hash-ref ->node from) (hash-ref ->node to))
(loop (cdddr xs))]
['() (void)])))
(map (lambda (nodes) (map node-id nodes)) (topological-sort (car nodes))))
(define (same-levels graph levels)
(define sorted (sort-graph graph))
(define (set=? l1 l2) (null? (append (remq* l1 l2) (remq* l2 l1))))
(andmap set=? sorted levels))
(provide topological-sort-tests)
(define (topological-sort-tests)
(test
do (with-graph [A B C]
A -> B -> C
(test (topological-sort A values) => (list A B C)))
(same-levels '(A -> B -> C)
'((A) (B) (C)))
do (with-graph [A B C]
;; check that a cycle doesn't lead to dropping nodes
A -> B -> C -> A
A -> C -> B -> A
(null? (remq* (topological-sort A values) (list A B C))))
(same-levels '(A -> B -> C -> A
A -> C -> B -> A)
'((A) (B C)))
do (with-graph [A B C D]
A -> B -> C -> D
A -> D
(test (topological-sort A values) => (list A B C D)))
(same-levels '(A -> B -> C -> D
A -> D)
'((A) (B) (C) (D)))
do (with-graph [A B C]
A -> B
A -> C
C -> C
(test (memq C (topological-sort A))))
(same-levels '(A -> B
A -> C
C -> C)
'((A) (B C)))
do (with-graph [A B C D]
A -> B
A -> C -> D
A -> D -> C
(test (memq C (topological-sort A))))
(same-levels '(A -> B
A -> C -> D
A -> D -> C)
'((A) (B C D)))
))