From e7f8cce4691c13f3b320f2bc064353b0c9539589 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 17 Jan 2009 23:36:33 +0000
Subject: [PATCH] added another capability to redex's traces function

svn: r13195
---
 collects/redex/gui.ss            |  6 ++++--
 collects/redex/private/traces.ss | 21 ++++++++++++---------
 collects/redex/redex.scrbl       | 12 +++++++++---
 3 files changed, 25 insertions(+), 14 deletions(-)

diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss
index 4983c60e21..ffcf27c6a5 100644
--- a/collects/redex/gui.ss
+++ b/collects/redex/gui.ss
@@ -36,7 +36,8 @@
                #:colors (listof (list/c string? string?))
                #:scheme-colors? boolean?
                #:layout (-> any/c any/c)
-               #:edge-label-font (or/c #f (is-a?/c font%)))
+               #:edge-label-font (or/c #f (is-a?/c font%))
+               #:filter (-> any/c (or/c #f string?) any/c))
               any)]
  [traces/ps (->* (reduction-relation?
                   any/c
@@ -48,7 +49,8 @@
                   #:pp pp-contract
                   #:colors (listof any/c)
                   #:layout (-> any/c any/c)
-                  #:edge-label-font (or/c #f (is-a?/c font%)))
+                  #:edge-label-font (or/c #f (is-a?/c font%))
+                  #:filter (-> any/c (or/c #f string?) any/c))
                  any)]
  
  [term-node? (-> any/c boolean?)]
diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss
index 57befd42bf..e1e4261d5e 100644
--- a/collects/redex/private/traces.ss
+++ b/collects/redex/private/traces.ss
@@ -133,7 +133,7 @@
                    #:colors [colors '()]
                    #:layout [layout void]
                    #:edge-label-font [edge-label-font #f]
-                   )
+                   #:filter [term-filter (lambda (x y) #t)])
   (let-values ([(graph-pb canvas)
                 (traces reductions pre-exprs
                         #:no-show-frame? #t
@@ -143,7 +143,8 @@
                         #:scheme-colors? scheme-colors?
                         #:colors colors
                         #:layout layout
-                        #:edge-label-font edge-label-font)])
+                        #:edge-label-font edge-label-font
+                        #:filter term-filter)])
     (print-to-ps graph-pb canvas filename)))
 
 (define (print-to-ps graph-pb canvas filename)
@@ -231,6 +232,7 @@
                 #:scheme-colors? [scheme-colors? #t]
                 #:layout [layout void]
                 #:edge-label-font [edge-label-font #f]
+                #:filter [term-filter (lambda (x y) #t)]
                 #:no-show-frame? [no-show-frame? #f])
   (define exprs (if multiple? pre-exprs (list pre-exprs)))
   (define main-eventspace (current-eventspace))
@@ -400,13 +402,14 @@
                            (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
-                                                                dark-pen-color
-                                                                light-pen-color) 
-                                              (red->colors name)])
-                                  (build-snip snip-cache snip sexp pred pp name scheme-colors? 
-                                              light-arrow-color dark-arrow-color dark-label-color light-label-color
-                                              dark-pen-color light-pen-color))))))
+                                (and (term-filter sexp name)
+                                     (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 name scheme-colors? 
+                                                   light-arrow-color dark-arrow-color dark-label-color light-label-color
+                                                   dark-pen-color light-pen-color)))))))
                          (apply-reduction-relation/tag-with-names reductions (send snip get-expr))))]
                   [new-y 
                    (call-on-eventspace-main-thread
diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl
index 1b35f0eafd..8c5504304b 100644
--- a/collects/redex/redex.scrbl
+++ b/collects/redex/redex.scrbl
@@ -1156,8 +1156,9 @@ exploring reduction sequences.
                            (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)]
+	         [#:scheme-colors? scheme-colors? boolean? #t]
+                 [#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
+                 [#:layout layout (-> (listof term-node?) void) void]
                  [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
          void?]{
 
@@ -1217,6 +1218,10 @@ The @scheme[scheme-colors?] argument, if @scheme[#t] causes
 to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
 @scheme[traces] just uses black for the color scheme.
 
+The @scheme[term-filter] function is called each time a new node is
+about to be inserted into the graph. If the filter returns false, the
+node is not inserted into the graph.
+
 The @scheme[layout] argument is called (with all of the terms) when
 new terms is inserted into the window. In general, it is called when
 after new terms are inserted in response to the user clicking on the
@@ -1242,7 +1247,8 @@ font is used.
                                 (any output-port number (is-a?/c text%) -> void))
                           default-pretty-printer]
                     [#:colors colors (listof (list string string)) '()]
-                    [#:layout layout (-> (listof term-node?) void)]
+                    [#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
+                    [#:layout layout (-> (listof term-node?) void) void]
                     [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
          void?]{