added support for special-case drawing of individual edges to the graph library and support to be able to use that to redex
svn: r13226
This commit is contained in:
Robby Findler
parent
49fd5085d0
commit
af810c8a6f
|
|
@ -1115,6 +1115,8 @@ profile todo:
|
|||
(send src lock #f))))))
|
||||
sorted)
|
||||
|
||||
(printf "sorted ~s\n" sorted)
|
||||
|
||||
;; clear out old annotations (and thaw colorers)
|
||||
(when internal-clear-test-coverage-display
|
||||
(internal-clear-test-coverage-display)
|
||||
|
|
|
|||
|
|
@ -231,7 +231,8 @@
|
|||
(mixin ((class->interface pasteboard%)) (graph-pasteboard<%>)
|
||||
(inherit find-first-snip find-next-selected-snip)
|
||||
|
||||
(init-field [edge-label-font #f])
|
||||
(init-field [edge-label-font #f]
|
||||
[edge-labels? #t])
|
||||
|
||||
(define draw-arrow-heads? #t)
|
||||
(inherit refresh get-admin)
|
||||
|
|
@ -535,12 +536,12 @@
|
|||
[(b45x b45y) (values s5x s4y)]
|
||||
[(b56x b56y) (values s5x s6y)])
|
||||
|
||||
(update-polygon s4x s4y sx s4y)
|
||||
(update-arrowhead-polygon s4x s4y sx s4y)
|
||||
(send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y))
|
||||
(send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y))
|
||||
(send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y))
|
||||
|
||||
(when (link-label the-link)
|
||||
(when (and edge-labels? (link-label the-link))
|
||||
(let* ((textlen (get-text-length (link-label the-link)))
|
||||
(linelen (- s6x s3x))
|
||||
(offset (* 1/2 (- linelen textlen))))
|
||||
|
|
@ -606,19 +607,8 @@
|
|||
;; the snips overlap, draw nothing
|
||||
(void)]
|
||||
[else
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))
|
||||
(update-polygon from-x from-y to-x to-y)
|
||||
(when (and draw-arrow-heads?
|
||||
(arrow-point-ok? (send point1 get-x) (send point1 get-y))
|
||||
(arrow-point-ok? (send point2 get-x) (send point2 get-y))
|
||||
(arrow-point-ok? (send point3 get-x) (send point3 get-y))
|
||||
(arrow-point-ok? (send point4 get-x) (send point4 get-y)))
|
||||
;; the arrowhead is not overlapping the snips, so draw it
|
||||
;; (this is only an approximate test, but probably good enough)
|
||||
(send dc draw-polygon points dx dy))
|
||||
(when (named-link? from-link)
|
||||
(draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
|
||||
(when (and edge-labels? (link-label from-link))
|
||||
(let-values ([(text-len h d v) (send dc get-text-extent (link-label from-link))])
|
||||
(let* ([arrow-end-x (send point3 get-x)]
|
||||
[arrow-end-y (send point3 get-y)]
|
||||
|
|
@ -628,15 +618,14 @@
|
|||
(- (* 1/2 vec)
|
||||
(make-polar (/ text-len 2) (angle vec))))])
|
||||
(when (> (sqrt (+ (sqr (- arrow-end-x from-x))
|
||||
(sqr (- arrow-end-y from-y))))
|
||||
text-len)
|
||||
(sqr (- arrow-end-y from-y))))
|
||||
text-len)
|
||||
(send dc draw-text (link-label from-link)
|
||||
(+ dx (real-part middle))
|
||||
(+ dy (imag-part middle))
|
||||
#f
|
||||
0
|
||||
(- (angle vec)))))))]))))))))
|
||||
(define (named-link? l) (link-label l))
|
||||
|
||||
(define (set-pen/brush from-link dark-lines?)
|
||||
(send dc set-brush
|
||||
|
|
@ -678,6 +667,20 @@
|
|||
(send dc set-text-foreground old-fg)
|
||||
(send dc set-brush old-brush))))
|
||||
|
||||
(define/public (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
|
||||
(send dc draw-line
|
||||
(+ dx from-x) (+ dy from-y)
|
||||
(+ dx to-x) (+ dy to-y))
|
||||
(update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4)
|
||||
(when (and draw-arrow-heads?
|
||||
(arrow-point-ok? (send point1 get-x) (send point1 get-y))
|
||||
(arrow-point-ok? (send point2 get-x) (send point2 get-y))
|
||||
(arrow-point-ok? (send point3 get-x) (send point3 get-y))
|
||||
(arrow-point-ok? (send point4 get-x) (send point4 get-y)))
|
||||
;; the arrowhead is not overlapping the snips, so draw it
|
||||
;; (this is only an approximate test, but probably good enough)
|
||||
(send dc draw-polygon points dx dy)))
|
||||
|
||||
;; for-each-to-redraw : number number number number (link snip -> void)
|
||||
(define/private (for-each-to-redraw left top right bottom f)
|
||||
(let ()
|
||||
|
|
@ -727,11 +730,11 @@
|
|||
[point4 (make-object point% 0 0)]
|
||||
[points (list point1 point2 point3 point4)])
|
||||
|
||||
;; update-polygon : number^4 -> void
|
||||
;; update-arrowhead-polygon : number^4 -> void
|
||||
;; updates points1, 2, and 3 with the arrow head's
|
||||
;; points. Use a turtle-like movement to find the points.
|
||||
;; point3 is the point where the line should end.
|
||||
(define/private (update-polygon from-x from-y to-x to-y)
|
||||
(define/public (update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4)
|
||||
(define (move tx ty ta d) (values (+ tx (* d (cos ta)))
|
||||
(+ ty (* d (sin ta)))
|
||||
ta))
|
||||
|
|
|
|||
|
|
@ -60,5 +60,51 @@ different nodes.
|
|||
is @scheme[#t].
|
||||
}
|
||||
|
||||
@defmethod[(draw-single-edge [dc (is-a?/c dc<%>)]
|
||||
[dx real?]
|
||||
[dy real?]
|
||||
[from (is-a?/c graph-snip<%>)]
|
||||
[to (is-a?/c graph-snip<%>)]
|
||||
[from-x real?]
|
||||
[from-y real?]
|
||||
[to-x real?]
|
||||
[to-y real?]
|
||||
[arrow-point-ok? (-> real? real? boolean?)]) void?]{
|
||||
|
||||
This method is called to draw each edge in the graph, except
|
||||
for the edges that connect a node to itself.
|
||||
|
||||
The @scheme[dc], @scheme[dx], and @scheme[dy] arguments are
|
||||
the same as in @method[editor<%> on-paint].
|
||||
|
||||
The
|
||||
@scheme[from-x], @scheme[from-y], @scheme[to-x], and
|
||||
@scheme[to-y] arguments specify points on the source and
|
||||
destination snip's bounding box where a straight line
|
||||
between the centers of the snip would intersect.
|
||||
|
||||
The @scheme[arrow-point-ok?] function returns @scheme[#t]
|
||||
when the point specified by its arguments is inside the the
|
||||
smallest rectangle that covers both the source and
|
||||
destination snips, but is outside of both of the rectangles
|
||||
that surround the source and destination snips themselves.
|
||||
|
||||
This default implementation uses @scheme[update-polygon] to compute
|
||||
the arrowheads and otherwise draws a straight line between the two
|
||||
points and then the arrowheads, unless the arrowhead points
|
||||
are not ok according to @scheme[arrow-point-ok?], in which case
|
||||
it just draws the line.
|
||||
}
|
||||
|
||||
@defmethod[(update-arrowhead-polygon [from-x real?] [from-y real?] [to-x real?] [to-y real?]
|
||||
[point1 (is-a?/c point%)]
|
||||
[point2 (is-a?/c point%)]
|
||||
[point3 (is-a?/c point%)]
|
||||
[point4 (is-a?/c point%)]) void?]{
|
||||
|
||||
Updates the arguments @scheme[point1], @scheme[point2], @scheme[point3], @scheme[point4] with the coordinates
|
||||
of an arrowhead for a line that connects (@scheme[from-x],@scheme[from-y]) to (@scheme[to-x],@scheme[to-y]).
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,11 @@
|
|||
|
||||
@defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{
|
||||
|
||||
@defconstructor/auto-super[([edge-label-font (or/c #f (is-a?/c font%)) #f])]{
|
||||
@defconstructor/auto-super[([edge-labels? boolean? #t]
|
||||
[edge-label-font (or/c #f (is-a?/c font%)) #f])]{
|
||||
|
||||
If @scheme[edge-labels?] is @scheme[#f], no edge labels are
|
||||
drawn. Otherwise, they are.
|
||||
|
||||
If @scheme[edge-label-font] is supplied, it is used when drawing the
|
||||
labels on the edges. Otherwise, the font is not set before drawing
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
"private/matcher.ss"
|
||||
"private/reduction-semantics.ss"
|
||||
"private/size-snip.ss"
|
||||
mrlib/graph
|
||||
scheme/contract
|
||||
scheme/class
|
||||
scheme/gui/base)
|
||||
|
|
@ -37,7 +38,9 @@
|
|||
#:scheme-colors? boolean?
|
||||
#:layout (-> any/c any/c)
|
||||
#:edge-label-font (or/c #f (is-a?/c font%))
|
||||
#:filter (-> any/c (or/c #f string?) any/c))
|
||||
#:edge-labels? boolean?
|
||||
#:filter (-> any/c (or/c #f string?) any/c)
|
||||
#:graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>))
|
||||
any)]
|
||||
[traces/ps (->* (reduction-relation?
|
||||
any/c
|
||||
|
|
@ -50,7 +53,9 @@
|
|||
#:colors (listof any/c)
|
||||
#:layout (-> any/c any/c)
|
||||
#:edge-label-font (or/c #f (is-a?/c font%))
|
||||
#:filter (-> any/c (or/c #f string?) any/c))
|
||||
#:edge-labels? boolean?
|
||||
#:filter (-> any/c (or/c #f string?) any/c)
|
||||
#:graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>))
|
||||
any)]
|
||||
|
||||
[term-node? (-> any/c boolean?)]
|
||||
|
|
|
|||
|
|
@ -133,6 +133,8 @@
|
|||
#:colors [colors '()]
|
||||
#:layout [layout void]
|
||||
#:edge-label-font [edge-label-font #f]
|
||||
#:edge-labels? [edge-labels? #t]
|
||||
#:graph-pasteboard-mixin [extra-graph-pasteboard-mixin values]
|
||||
#:filter [term-filter (lambda (x y) #t)])
|
||||
(let-values ([(graph-pb canvas)
|
||||
(traces reductions pre-exprs
|
||||
|
|
@ -144,6 +146,8 @@
|
|||
#:colors colors
|
||||
#:layout layout
|
||||
#:edge-label-font edge-label-font
|
||||
#:edge-labels? edge-labels?
|
||||
#:graph-pasteboard-mixin extra-graph-pasteboard-mixin
|
||||
#:filter term-filter)])
|
||||
(print-to-ps graph-pb canvas filename)))
|
||||
|
||||
|
|
@ -232,12 +236,14 @@
|
|||
#:scheme-colors? [scheme-colors? #t]
|
||||
#:layout [layout void]
|
||||
#:edge-label-font [edge-label-font #f]
|
||||
#:edge-labels? [edge-labels? #t]
|
||||
#:filter [term-filter (lambda (x y) #t)]
|
||||
#:graph-pasteboard-mixin [extra-graph-pasteboard-mixin values]
|
||||
#: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))
|
||||
(define graph-pb (new graph-pasteboard% [layout layout] [edge-label-font edge-label-font]))
|
||||
(define graph-pb (new (extra-graph-pasteboard-mixin graph-pasteboard%) [layout layout] [edge-label-font edge-label-font] [edge-labels? edge-labels?]))
|
||||
(define user-char-width (initial-char-width))
|
||||
(define f (instantiate red-sem-frame% ()
|
||||
(label "PLT Redex Reduction Graph")
|
||||
|
|
|
|||
|
|
@ -4,11 +4,12 @@
|
|||
scribble/eval
|
||||
(for-syntax scheme/base)
|
||||
(for-label scheme/base
|
||||
scheme/gui
|
||||
scheme/gui
|
||||
scheme/pretty
|
||||
scheme/contract
|
||||
(only-in slideshow/pict pict? text dc-for-text-size)
|
||||
redex))
|
||||
mrlib/graph
|
||||
(only-in slideshow/pict pict? text dc-for-text-size)
|
||||
redex))
|
||||
|
||||
@(define-syntax (defpattech stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -378,7 +379,7 @@ stands for repetition unless otherwise indicated):
|
|||
(in-hole term term)
|
||||
hole
|
||||
#t #f
|
||||
string]
|
||||
string]
|
||||
[term-sequence
|
||||
term
|
||||
,@scheme-expression
|
||||
|
|
@ -1156,10 +1157,12 @@ 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? #t]
|
||||
[#: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])
|
||||
[#:edge-labels? edge-label-font boolean? #t]
|
||||
[#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]
|
||||
[#:graph-pasteboard-mixin graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>) values])
|
||||
void?]{
|
||||
|
||||
This function opens a new window and inserts each expression
|
||||
|
|
@ -1228,10 +1231,23 @@ after new terms are inserted in response to the user clicking on the
|
|||
reduce button, and after the initial set of terms is inserted.
|
||||
See also @scheme[term-node-set-position!].
|
||||
|
||||
If @scheme[edge-labels?] is @scheme[#t] (the default), then edge labels
|
||||
are drawn; otherwise not.
|
||||
|
||||
The @scheme[edge-label-font] argument is used as the font on the edge
|
||||
labels. If nothign is suppled, the @scheme[dc<%>] object's default
|
||||
labels. If @scheme[#f] is suppled, the @scheme[dc<%>] object's default
|
||||
font is used.
|
||||
|
||||
The traces library an instance of the @schememodname[mrlib/graph]
|
||||
library's @scheme[graph-pasteboard<%>] interface to layout
|
||||
the graphs. Sometimes, overriding one of its methods can
|
||||
help give finer-grained control over the layout, so the
|
||||
@scheme[graph-pasteboard-mixin] is applied to the class
|
||||
before it is instantiated. Also note that all of the snips
|
||||
inserted into the editor by this library have a
|
||||
@tt{get-term-node} method which returns the snip's
|
||||
@scheme[term-node].
|
||||
|
||||
}
|
||||
|
||||
@defproc[(traces/ps [reductions reduction-relation?]
|
||||
|
|
@ -1249,7 +1265,9 @@ font is used.
|
|||
[#:colors colors (listof (list string string)) '()]
|
||||
[#: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-labels? edge-label-font boolean? #t]
|
||||
[#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]
|
||||
[#:graph-pasteboard-mixin graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>) values])
|
||||
void?]{
|
||||
|
||||
The arguments behave just like the function @scheme[traces], but
|
||||
|
|
|
|||
|
|
@ -3,6 +3,9 @@ v4.1.4
|
|||
- initial-char-width now accepts functions to give finer grained
|
||||
control of the initial widths of the terms.
|
||||
|
||||
- traces & traces/ps: added the ability to specify a mixin
|
||||
to be mixed into the graph pasteboard
|
||||
|
||||
v4.1.3
|
||||
|
||||
* added redex-check, a tool for automatically generating test cases
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user