better layout for topological-sort

svn: r14834

original commit: 27e4c708c791a732f9c5fe016159c450ed3605f2

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
+  (let* ([nodes (topological-sort *-node)]
-                             *-node
+         [nodes (append-map (lambda (nodes) (sort nodes > #:key node-total))
-                             (lambda (nodes)
+                            nodes)]
-                               (sort nodes > #:key node-total))))])
+         [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))

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

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))
+  (define edge (make-edge 0 from 0 to 0))
-  (set-node-callers! to   (cons e (node-callers to  )))
+  (set-node-callers! to   (cons edge (node-callers to  )))
-  (set-node-callees! from (cons e (node-callees from))))
+  (set-node-callees! from (cons edge (node-callees from))))
 
-(define-syntax with-graph
+(define (sort-graph . edges)
-  (syntax-rules (->)
+  (define names (remove-duplicates (remq* '(->) (append* edges))))
-    [(_ [] <from> -> <to> -> more ...)
+  (define nodes (map (lambda (sym) (make-node sym #f '() 0 0 '() '())) names))
-     (begin (connect! <from> <to>) (with-graph [] <to> -> more ...))]
+  (define ->node (make-immutable-hasheq (map cons names nodes)))
-    [(_ [] <from> -> <to> more ...)
+  (for ([edges edges])
-     (begin (connect! <from> <to>) (with-graph [] more ...))]
+    (let loop ([xs edges])
-    [(_ [] more ...) (begin more ...)]
+      (match xs
-    [(_ [<id> ...] more ...)
+        [(list from '-> to '-> _ ...)
-     (let ([<id> (make-node '<id> #f '() 0 0 '() '())] ...)
+         (connect! (hash-ref ->node from) (hash-ref ->node to))
-       (with-graph [] more ...))]))
+         (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]
+    (same-levels '(A -> B -> C)
-         A -> B -> C
+                 '((A) (B) (C)))
-         (test (topological-sort A values) => (list A B C)))
 
-    do (with-graph [A B C]
+    (same-levels '(A -> B -> C -> A
-         ;; check that a cycle doesn't lead to dropping nodes
+                   A -> C -> B -> A)
-         A -> B -> C -> A
+                 '((A) (B C)))
-         A -> C -> B -> A
-         (null? (remq* (topological-sort A values) (list A B C))))
 
-    do (with-graph [A B C D]
+    (same-levels '(A -> B -> C -> D
-         A -> B -> C -> D
+                   A -> D)
-         A -> D
+                 '((A) (B) (C) (D)))
-         (test (topological-sort A values) => (list A B C D)))
 
-    do (with-graph [A B C]
+    (same-levels '(A -> B
-         A -> B
+                   A -> C
-         A -> C
+                   C -> C)
-         C -> C
+                 '((A) (B C)))
-         (test (memq C (topological-sort A))))
 
-    do (with-graph [A B C D]
+    (same-levels '(A -> B
-         A -> B
+                   A -> C -> D
-         A -> C -> D
+                   A -> D -> C)
-         A -> D -> C
+                 '((A) (B C D)))
-         (test (memq C (topological-sort A))))
 
     ))