added traces/ps and some code to make automatic layout of the graph possible (see #:layout in the docs for traces)

svn: r13058

collects/redex/HISTORY

@@ -1,3 +1,10 @@
+  - added more coloring arguments to traces: #:scheme-colors? 
+  #:default-arrow-highlight-color, and #:default-arrow-color
+
+  - added the #:layout argument to traces 
+
+  - added term-node-set-position!
+
   - Added tracing to metafunctions (see current-traced-metafunctions)
 
   - added caching-enabled? parameter (changed how set-cache-size! 

collects/redex/gui.ss

@@ -33,8 +33,21 @@
                #:pred (or/c (any/c . -> . any)
                             (any/c term-node? . -> . any))
                #:pp pp-contract
-               #:colors (listof any/c))
+               #:colors (listof (list/c string? string?))
+               #:scheme-colors? boolean?
+               #:layout (-> any/c any/c))
               any)]
+ [traces/ps (->* (reduction-relation?
+                  any/c
+                  (or/c path-string? path?))
+                 (#:multiple?
+                  boolean?
+                  #:pred (or/c (any/c . -> . any)
+                               (any/c term-node? . -> . any))
+                  #:pp pp-contract
+                  #:colors (listof any/c)
+                  #:layout (-> any/c any/c))
+                 any)]
  
  [term-node? (-> any/c boolean?)]
  [term-node-parents (-> term-node? (listof term-node?))]
@@ -45,6 +58,11 @@
                            (or/c string? (is-a?/c color%) false/c)
                            void?)]
  [term-node-expr (-> term-node? any)]
+ [term-node-set-position! (-> term-node? real? real? void?)]
+ [term-node-x (-> term-node? real?)]
+ [term-node-y (-> term-node? real?)]
+ [term-node-width (-> term-node? real?)]
+ [term-node-height (-> term-node? real?)]
  
  [stepper
   (->* (reduction-relation?
@@ -55,10 +73,16 @@
   (->* (reduction-relation?
         (cons/c any/c (listof any/c)))
        (pp-contract)
-       void?)])
+       void?)]
-
+ 
-
+ [dark-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
-(provide reduction-steps-cutoff initial-font-size initial-char-width
+ [light-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
-         dark-pen-color light-pen-color dark-brush-color light-brush-color
+ [dark-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
-         dark-text-color light-text-color
+ [light-brush-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [dark-text-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [light-text-color (parameter/c (or/c string? (is-a?/c color%)))]
+ [initial-font-size (parameter/c number?)]
+ [initial-char-width (parameter/c number?)])
+         
+(provide reduction-steps-cutoff
          default-pretty-printer)

collects/redex/private/traces.ss

@@ -30,15 +30,87 @@
 (define (term-node-expr term-node) (send (term-node-snip term-node) get-expr))
 (define (term-node-labels term-node) (send (term-node-snip term-node) get-one-step-labels))
 (define (term-node-set-color! term-node r?)
-  (let loop ([snip (term-node-snip term-node)])
+  (snip/eventspace
-    (parameterize ([current-eventspace (send snip get-my-eventspace)])
+   (λ ()
-      (queue-callback
+     (send (term-node-snip term-node) set-bad r?))))
-       (λ ()
-         (send (term-node-snip term-node) set-bad r?))))))
 
 (define (term-node-set-red! term-node r?)
   (term-node-set-color! term-node (and r? "pink")))
 
+(define (term-node-set-position! term-node x y)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (when ed
+       (send ed move-to (term-node-snip term-node) x y)))))
+
+(define (term-node-width term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([lb (box 0)]
+           [rb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (and (send ed get-snip-location snip lb #f #f)
+                (send ed get-snip-location snip rb #f #t))
+           (- (unbox rb) (unbox lb))
+           0)))))
+
+(define (term-node-height term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([tb (box 0)]
+           [bb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (and (send ed get-snip-location snip #f tb #f)
+                (send ed get-snip-location snip #f bb #t))
+           (- (unbox bb) (unbox tb))
+           0)))))
+
+(define (term-node-x term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([xb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (send ed get-snip-location snip xb #f #f)
+           (unbox xb)
+           0)))))
+
+(define (term-node-y term-node)
+  (snip/eventspace/ed 
+   term-node
+   (λ (ed)
+     (let ([yb (box 0)]
+           [snip (term-node-snip term-node)])
+       (if (send ed get-snip-location snip yb #f #f)
+           (unbox yb)
+           0)))))
+
+(define (snip/eventspace/ed term-node f)
+  (snip/eventspace 
+   term-node
+   (λ ()
+     (let* ([snip (term-node-snip term-node)]
+            [admin (send snip get-admin)])
+       (f (and admin (send admin get-editor)))))))
+
+  
+(define (snip/eventspace term-node thunk)
+  (let* ([snip (term-node-snip term-node)]
+         [eventspace (send snip get-my-eventspace)])
+    (cond
+      [(eq? (current-eventspace) eventspace)
+       (thunk)]
+      [else
+       (let ([c (make-channel)])
+         (parameterize ([current-eventspace eventspace])
+           (queue-callback
+            (λ ()
+              (channel-put c (thunk)))))
+         (channel-get c))])))
+
 (define initial-font-size
   (make-parameter
    (send (send (send (editor:get-standard-style-list) 
@@ -51,7 +123,39 @@
 (define x-spacing 15)
 (define y-spacing 15)
 
-(define (traces reductions pre-exprs #:multiple? [multiple? #f] #:pred [pred (λ (x) #t)] #:pp [pp default-pretty-printer] #:colors [colors '()])
+(define (traces/ps reductions pre-exprs filename
+                   #:multiple? [multiple? #f] 
+                   #:pred [pred (λ (x) #t)] 
+                   #:pp [pp default-pretty-printer] 
+                   #:default-arrow-colors [default-arrow-colors '()]
+                   #:scheme-colors? [scheme-colors? #t]
+                   #:colors [colors '()]
+                   #:layout [layout void])
+  (let ([graph-pb
+         (traces reductions pre-exprs
+                 #:no-show-frame? #t
+                 #:multiple? multiple? 
+                 #:pred pred
+                 #:pp pp
+                 #:default-arrow-colors default-arrow-colors
+                 #:scheme-colors? scheme-colors?
+                 #:colors colors
+                 #:layout layout)]
+        [ps-setup (make-object ps-setup%)])
+    (send ps-setup copy-from (current-ps-setup))
+    (send ps-setup set-file filename)
+    (send ps-setup set-mode 'file)
+    (parameterize ([current-ps-setup ps-setup])
+      (send graph-pb print #t #f 'postscript #f #f))))
+
+(define (traces reductions pre-exprs 
+                #:multiple? [multiple? #f] 
+                #:pred [pred (λ (x) #t)] 
+                #:pp [pp default-pretty-printer] 
+                #:colors [colors '()]
+                #:scheme-colors? [scheme-colors? #t]
+                #:layout [layout void]
+                #:no-show-frame? [no-show-frame? #f])
   (define exprs (if multiple? pre-exprs (list pre-exprs)))
   (define main-eventspace (current-eventspace))
   (define saved-parameterization (current-parameterization))
@@ -146,14 +250,18 @@
         (semaphore-wait s)
         ans)))
   
+  (define default-colors (list (dark-pen-color) (light-pen-color) 
+                               (dark-text-color) (light-text-color)
+                               (dark-brush-color) (light-brush-color)))
+  
   ;; only changed on the reduction thread
   ;; frontier : (listof (is-a?/c graph-editor-snip%))
   (define frontier 
     (filter
      (λ (x) x)
-     (map (lambda (expr) (build-snip snip-cache #f expr pred pp 
+     (map (lambda (expr) (apply build-snip
-                                     (dark-pen-color) (light-pen-color)
+                                snip-cache #f expr pred pp #f scheme-colors?
-                                     (dark-text-color) (light-text-color) #f))
+                                default-colors))
           exprs)))
   
   ;; set-font-size : number -> void
@@ -172,38 +280,29 @@
             (send snip shrink-down))
           (loop (send snip next))))))
   
-  ;; color-spec-list->color-scheme : (list (union string? #f)^4) -> (list string?^4)
+  ;; fill-out : (listof X) (listof X) -> (listof X)
-  ;; converts a list of user-specified colors (including false) into a list of color strings, filling in
+  ;; produces a list whose length matches defaults but
-  ;; falses with the default colors
+  (define (fill-out l defaults)
-  (define (color-spec-list->color-scheme l)
+    (let loop ([l l]
-    (map (λ (c d) (or c d))
+               [default defaults])
-         l 
+      (cond
-         (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))
+        [(null? l) defaults]
-  
+        [else 
+         (cons (car l) (loop (cdr l) (cdr defaults)))])))
   
   (define name->color-ht 
     (let ((ht (make-hash)))
       (for-each 
        (λ (c)
-         (hash-set! ht (car c) 
+         (hash-set! ht (car c) (fill-out (cdr c) default-colors)))
-                    (color-spec-list->color-scheme
-                     (match (cdr c)
-                       [`(,color)
-                        (list color color (dark-text-color) (light-text-color))]
-                       [`(,dark-arrow-color ,light-arrow-color)
-                        (list dark-arrow-color light-arrow-color (dark-text-color) (light-text-color))]
-                       [`(,dark-arrow-color ,light-arrow-color ,text-color) 
-                        (list dark-arrow-color light-arrow-color text-color text-color)]
-                       [`(,_ ,_ ,_ ,_)
-                        (cdr c)]))))
        colors)
       ht))
   
-  ;; red->colors : string -> (values string string string string)
+  ;; red->colors : string -> (values string string string string string string)
   (define (red->colors reduction-name)
     (apply values (hash-ref name->color-ht
                             reduction-name 
-                            (λ () (list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))))
+                            default-colors)))
   
   ;; reduce-frontier : -> void
   ;; =reduction thread=
@@ -225,11 +324,13 @@
                            (let-values ([(name sexp) (apply values red+sexp)])
                              (call-on-eventspace-main-thread
                               (λ ()
-                                (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color) 
+                                (let-values ([(dark-arrow-color light-arrow-color dark-label-color light-label-color
+                                                                dark-pen-color
+                                                                light-pen-color) 
                                               (red->colors name)])
-                                  (build-snip snip-cache snip sexp pred pp 
+                                  (build-snip snip-cache snip sexp pred pp name scheme-colors? 
                                               light-arrow-color dark-arrow-color dark-label-color light-label-color
-                                              name))))))
+                                              dark-pen-color light-pen-color))))))
                          (apply-reduction-relation/tag-with-names reductions (send snip get-expr))))]
                   [new-y 
                    (call-on-eventspace-main-thread
@@ -239,6 +340,7 @@
                         (set! col (+ x-spacing (find-rightmost-x graph-pb))))
                       (begin0
                         (insert-into col y graph-pb new-snips)
+                        (layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
                         (send graph-pb end-edit-sequence)
                         (send status-message set-label
                               (string-append (term-count (count-snips)) "...")))))])
@@ -369,9 +471,12 @@
               null)))
   (out-of-dot-state) ;; make sure the state is initialized right
   (insert-into init-rightmost-x 0 graph-pb frontier)
+  (layout (map (lambda (y) (send y get-term-node)) frontier))
   (set-font-size (initial-font-size))
   (reduce-button-callback)
-  (send f show #t))
+  (if no-show-frame?
+      graph-pb
+      (send f show #t)))
 
 (define red-sem-frame%
   (class (frame:standard-menus-mixin (frame:basic-mixin frame%))
@@ -509,20 +614,22 @@
 ;;              sexp
 ;;              sexp -> boolean
 ;;              (any port number -> void)
-;;              color
 ;;              (union #f string)
+;;              color^6
 ;;           -> (union #f (is-a?/c graph-editor-snip%))
 ;; returns #f if a snip corresponding to the expr has already been created.
 ;; also adds in the links to the parent snip
 ;; =eventspace main thread=
-(define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name)
+(define (build-snip cache parent-snip expr pred pp name scheme-colors?
+                    light-arrow-color dark-arrow-color dark-label-color light-label-color
+                    dark-brush-color light-brush-color)
   (let-values ([(snip new?)
                 (let/ec k
                   (values (hash-ref
                            cache
                            expr
                            (lambda ()
-                             (let ([new-snip (make-snip parent-snip expr pred pp)])
+                             (let ([new-snip (make-snip parent-snip expr pred pp scheme-colors?)])
                                (hash-set! cache expr new-snip)
                                (k new-snip #t))))
                           #f))])
@@ -532,10 +639,14 @@
       (add-links/text-colors parent-snip snip
                              (send the-pen-list find-or-create-pen dark-arrow-color 0 'solid)
                              (send the-pen-list find-or-create-pen light-arrow-color 0 'solid)
-                             (send the-brush-list find-or-create-brush (dark-brush-color) 'solid)
+                             (send the-brush-list find-or-create-brush dark-brush-color 'solid)
-                             (send the-brush-list find-or-create-brush (light-brush-color) 'solid)
+                             (send the-brush-list find-or-create-brush light-brush-color 'solid)
-                             (make-object color% dark-label-color)
+                             (if (is-a? dark-label-color color%)
-                             (make-object color% light-label-color)
+                                 dark-label-color
+                                 (make-object color% dark-label-color))
+                             (if (is-a? light-label-color color%)
+                                 light-label-color
+                                 (make-object color% light-label-color))
                              0 0
                              name)
       (update-badness pred parent-snip (send parent-snip get-expr)))
@@ -563,7 +674,7 @@
 ;;          -> (is-a?/c graph-editor-snip%)
 ;; unconditionally creates a new graph-editor-snip
 ;; =eventspace main thread=
-(define (make-snip parent-snip expr pred pp)
+(define (make-snip parent-snip expr pred pp scheme-colors?)
   (let* ([text (new program-text%)]
          [es (instantiate graph-editor-snip% ()
                (char-width (initial-char-width))
@@ -573,6 +684,7 @@
                (expr expr))])
     (send text set-autowrap-bitmap #f)
     (send text freeze-colorer)
+    (send text stop-colorer (not scheme-colors?))
     (send es format-expr)
     es))
 
@@ -605,12 +717,18 @@
        (unbox bt))))
 
 (provide traces
+         traces/ps
          term-node?
          term-node-parents
          term-node-children
          term-node-labels 
          term-node-set-red!
          term-node-set-color!
+         term-node-set-position!
+         term-node-x
+         term-node-y
+         term-node-width
+         term-node-height
          term-node-expr)
 
 (provide reduction-steps-cutoff initial-font-size

collects/redex/redex.scrbl

@@ -1117,13 +1117,21 @@ exploring reduction sequences.
                  [expr (or/c any/c (listof any/c))]
                  [#:multiple? multiple? boolean? #f]
                  [#:pred pred
-                         (or/c (sexp -> any) (sexp term-node? any))
+                         (or/c (-> sexp any)
+                               (-> sexp term-node? any))
                          (lambda (x) #t)]
                  [#:pp pp
                        (or/c (any -> string)
                              (any output-port number (is-a?/c text%) -> void))
                        default-pretty-printer]
-                 [#:colors colors (listof (list string string)) '()])
+                 [#:colors colors 
+                  (listof 
+                   (cons/c string 
+                           (and/c (listof (or/c string? (is-a?/c color%)))
+                                  (lambda (x) (member (length x) '(2 3 4 6))))))]
+
+	         [#:scheme-colors? scheme-colors? boolean?]
+                 [#:layout layout (-> (listof term-node?) void)])
          void?]{
 
 This function opens a new window and inserts each expression
@@ -1163,14 +1171,56 @@ final argument is the text where the port is connected --
 characters written to the port go to the end of the editor.
 
 The @scheme[colors] argument, if provided, specifies a list of
-reduction-name/color-string pairs. The traces gui will color
+reduction-name/color-list pairs. The traces gui will color arrows
-arrows drawn because of the given reduction name with the
+drawn because of the given reduction name with the given color instead
-given color instead of using the default color.
+of using the default color.
+
+The @scheme[cdr] of each of the elements of @scheme[colors] is a list
+of colors, organized in pairs. The first two colors cover the colors
+of the line and the border around the arrow head, the first when the
+mouse is over a graph node that is connected to that arrow, and the
+second for when the mouse is not over that arrow. Similarly, the next
+colors are for the text drawn on the arrow and the last two are for
+the color that fills the arrow head.  If fewer than six colors are
+specified, the colors specified colors are used and then defaults are
+filled in for the remaining colors.
+
+
+
+The @scheme[scheme-colors?] argument, if @scheme[#t] causes
+@scheme[traces] to color the contents of each of the windows according
+to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
+@scheme[traces] just uses black for the color scheme.
+
+The @scheme[layout] argument is called (with all of the terms) each
+time a new term is inserted into the window. See also
+@scheme[term-node-set-position!].
 
 You can save the contents of the window as a postscript file
 from the menus.
 }
 
+@defproc[(traces/ps [reductions reduction-relation?] 
+                    [expr (or/c any/c (listof any/c))]
+                    [file (or/c path-string? path?)]
+                    [#:multiple? multiple? boolean? #f]
+                    [#:pred pred
+                            (or/c (-> sexp any)
+                                  (-> sexp term-node? any))
+                            (lambda (x) #t)]
+                    [#:pp pp
+                          (or/c (any -> string)
+                                (any output-port number (is-a?/c text%) -> void))
+                          default-pretty-printer]
+                    [#:colors colors (listof (list string string)) '()]
+                    [#:layout layout (-> (listof term-node?) void)])
+         void?]{
+
+The arguments behave just like the function @scheme[traces], but
+instead of opening a window to show the reduction graph, it just saves
+the reduction graph to the specified @scheme[file].
+}
+
 @defproc[(stepper [reductions reduction-relation?] 
                   [t any/c] 
                   [pp (or/c (any -> string)
@@ -1246,6 +1296,24 @@ not colored specially.
 Returns the expression in this node.
 }
 
+@defproc[(term-node-set-position! [tn term-node?] [x (and/c real? positive?)] [y (and/c real? positive?)]) void?]{
+
+Sets the position of @scheme[tn] in the graph to (@scheme[x],@scheme[y]). 
+}
+
+@defproc[(term-node-x [tn term-node?]) real]{
+Returns the @tt{x} coordinate of @scheme[tn] in the window.
+}
+@defproc[(term-node-y [tn term-node?]) real]{
+Returns the @tt{y} coordinate of @scheme[tn] in the window.
+}
+@defproc[(term-node-width [tn term-node?]) real]{
+Returns the width of @scheme[tn] in the window.
+}
+@defproc[(term-node-height [tn term-node?]) real?]{
+Returns the height of @scheme[tn] in the window.
+}
+
 @defproc[(term-node? [v any/c]) boolean?]{
 
 Recognizes term nodes.