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

added another capability to redex's traces function

Browse Source 
svn: r13195
This commit is contained in:
Robby Findler 2009-01-17 23:36:33 +00:00
parent 46bcdf9924
commit e7f8cce469
3 changed files with 25 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/redex/gui.ss
View File

@ -36,7 +36,8 @@
#:colors (listof (list/c string? string?)) #:colors (listof (list/c string? string?))
#:scheme-colors? boolean? #:scheme-colors? boolean?
#:layout (-> any/c 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)] any)]
[traces/ps (->* (reduction-relation? [traces/ps (->* (reduction-relation?
any/c any/c
@ -48,7 +49,8 @@
#:pp pp-contract #:pp pp-contract
#:colors (listof any/c) #:colors (listof any/c)
#:layout (-> any/c 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)] any)]
[term-node? (-> any/c boolean?)] [term-node? (-> any/c boolean?)]

9
collects/redex/private/traces.ss
View File

@ -133,7 +133,7 @@
#:colors [colors '()] #:colors [colors '()]
#:layout [layout void] #:layout [layout void]
#:edge-label-font [edge-label-font #f] #:edge-label-font [edge-label-font #f]
) #:filter [term-filter (lambda (x y) #t)])
(let-values ([(graph-pb canvas) (let-values ([(graph-pb canvas)
(traces reductions pre-exprs (traces reductions pre-exprs
#:no-show-frame? #t #:no-show-frame? #t
@ -143,7 +143,8 @@
#:scheme-colors? scheme-colors? #:scheme-colors? scheme-colors?
#:colors colors #:colors colors
#:layout layout #:layout layout
#:edge-label-font edge-label-font)]) #:edge-label-font edge-label-font
#:filter term-filter)])
(print-to-ps graph-pb canvas filename))) (print-to-ps graph-pb canvas filename)))
(define (print-to-ps graph-pb canvas filename) (define (print-to-ps graph-pb canvas filename)
@ -231,6 +232,7 @@
#:scheme-colors? [scheme-colors? #t] #:scheme-colors? [scheme-colors? #t]
#:layout [layout void] #:layout [layout void]
#:edge-label-font [edge-label-font #f] #:edge-label-font [edge-label-font #f]
#:filter [term-filter (lambda (x y) #t)]
#:no-show-frame? [no-show-frame? #f]) #:no-show-frame? [no-show-frame? #f])
(define exprs (if multiple? pre-exprs (list pre-exprs))) (define exprs (if multiple? pre-exprs (list pre-exprs)))
(define main-eventspace (current-eventspace)) (define main-eventspace (current-eventspace))
@ -400,13 +402,14 @@
(let-values ([(name sexp) (apply values red+sexp)]) (let-values ([(name sexp) (apply values red+sexp)])
(call-on-eventspace-main-thread (call-on-eventspace-main-thread
(λ () (λ ()
(and (term-filter sexp name)
(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 dark-pen-color
light-pen-color) light-pen-color)
(red->colors name)]) (red->colors name)])
(build-snip snip-cache snip sexp pred pp name scheme-colors? (build-snip snip-cache snip sexp pred pp name scheme-colors?
light-arrow-color dark-arrow-color dark-label-color light-label-color light-arrow-color dark-arrow-color dark-label-color light-label-color
dark-pen-color light-pen-color)))))) dark-pen-color light-pen-color)))))))
(apply-reduction-relation/tag-with-names reductions (send snip get-expr))))] (apply-reduction-relation/tag-with-names reductions (send snip get-expr))))]
[new-y [new-y
(call-on-eventspace-main-thread (call-on-eventspace-main-thread

12
collects/redex/redex.scrbl
View File

@ -1156,8 +1156,9 @@ exploring reduction sequences.
(and/c (listof (or/c string? (is-a?/c color%))) (and/c (listof (or/c string? (is-a?/c color%)))
(lambda (x) (member (length x) '(2 3 4 6))))))] (lambda (x) (member (length x) '(2 3 4 6))))))]
[#:scheme-colors? scheme-colors? boolean?] [#:scheme-colors? scheme-colors? boolean? #t]
[#: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]) [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
void?]{ 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], to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
@scheme[traces] just uses black for the color scheme. @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 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 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 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)) (any output-port number (is-a?/c text%) -> void))
default-pretty-printer] default-pretty-printer]
[#:colors colors (listof (list string string)) '()] [#: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]) [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
void?]{ void?]{