added traces/ps and some code to make automatic layout of the graph possible (see #:layout in the docs for traces)
svn: r13058
This commit is contained in:
Robby Findler
parent
630c8cbc54
commit
3a3ceb121b
|
|
@ -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!
|
||||
|
|
|
|||
|
|
@ -33,7 +33,20 @@
|
|||
#: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?)]
|
||||
|
|
@ -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%)))]
|
||||
[light-pen-color (parameter/c (or/c string? (is-a?/c color%)))]
|
||||
[dark-brush-color (parameter/c (or/c string? (is-a?/c 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 initial-font-size initial-char-width
|
||||
dark-pen-color light-pen-color dark-brush-color light-brush-color
|
||||
dark-text-color light-text-color
|
||||
(provide reduction-steps-cutoff
|
||||
default-pretty-printer)
|
||||
|
|
@ -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)])
|
||||
(parameterize ([current-eventspace (send snip get-my-eventspace)])
|
||||
(queue-callback
|
||||
(snip/eventspace
|
||||
(λ ()
|
||||
(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
|
||||
(dark-pen-color) (light-pen-color)
|
||||
(dark-text-color) (light-text-color) #f))
|
||||
(map (lambda (expr) (apply build-snip
|
||||
snip-cache #f expr pred pp #f scheme-colors?
|
||||
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)
|
||||
;; converts a list of user-specified colors (including false) into a list of color strings, filling in
|
||||
;; falses with the default colors
|
||||
(define (color-spec-list->color-scheme l)
|
||||
(map (λ (c d) (or c d))
|
||||
l
|
||||
(list (dark-pen-color) (light-pen-color) (dark-text-color) (light-text-color))))
|
||||
|
||||
;; fill-out : (listof X) (listof X) -> (listof X)
|
||||
;; produces a list whose length matches defaults but
|
||||
(define (fill-out l defaults)
|
||||
(let loop ([l l]
|
||||
[default defaults])
|
||||
(cond
|
||||
[(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)
|
||||
(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)]))))
|
||||
(hash-set! ht (car c) (fill-out (cdr c) default-colors)))
|
||||
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 (light-brush-color) 'solid)
|
||||
(make-object color% dark-label-color)
|
||||
(make-object color% light-label-color)
|
||||
(send the-brush-list find-or-create-brush dark-brush-color 'solid)
|
||||
(send the-brush-list find-or-create-brush light-brush-color 'solid)
|
||||
(if (is-a? dark-label-color 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
arrows drawn because of the given reduction name with the
|
||||
given color instead of using the default color.
|
||||
reduction-name/color-list pairs. The traces gui will color arrows
|
||||
drawn because of the given reduction name with the given color instead
|
||||
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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user