diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index e905c03a11..7195c23646 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -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) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 775208d6e2..214259d266 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -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)) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl index 6b8b051765..c1ef562951 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl @@ -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]). +} + } diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl index 09bdd124b2..0dd2a8ac35 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl @@ -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 diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss index 0977894e84..f6dfe309d5 100644 --- a/collects/redex/gui.ss +++ b/collects/redex/gui.ss @@ -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?)] diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 175945a751..2e35f26b87 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -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") diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index df244e859f..bf1a710ae1 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -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 diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 4dc7754550..f8bcb55b03 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -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