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?))
#: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?)]

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

@ -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

12
collects/redex/redex.scrbl
View File

@ -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?]{