From 2ac42691a8d8299c8260f9dc7d38925a76bb7a6e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 15 May 2009 19:16:56 +0000 Subject: [PATCH] better layout for topological-sort svn: r14834 original commit: 27e4c708c791a732f9c5fe016159c450ed3605f2 --- collects/profile/analyzer.ss | 8 ++-- collects/profile/utils.ss | 48 +++++++++---------- collects/tests/profile/topsort.ss | 77 ++++++++++++++++--------------- 3 files changed, 67 insertions(+), 66 deletions(-) diff --git a/collects/profile/analyzer.ss b/collects/profile/analyzer.ss index 4fed4e2..946e309 100644 --- a/collects/profile/analyzer.ss +++ b/collects/profile/analyzer.ss @@ -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)) diff --git a/collects/profile/utils.ss b/collects/profile/utils.ss index 944c59b..d94f02a 100644 --- a/collects/profile/utils.ss +++ b/collects/profile/utils.ss @@ -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)))))) diff --git a/collects/tests/profile/topsort.ss b/collects/tests/profile/topsort.ss index 4af71e2..7ab2160 100644 --- a/collects/tests/profile/topsort.ss +++ b/collects/tests/profile/topsort.ss @@ -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 (->) - [(_ [] -> -> more ...) - (begin (connect! ) (with-graph [] -> more ...))] - [(_ [] -> more ...) - (begin (connect! ) (with-graph [] more ...))] - [(_ [] more ...) (begin more ...)] - [(_ [ ...] more ...) - (let ([ (make-node ' #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))) ))