diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 83b692a938..775208d6e2 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -231,6 +231,8 @@ (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>) (inherit find-first-snip find-next-selected-snip) + (init-field [edge-label-font #f]) + (define draw-arrow-heads? #t) (inherit refresh get-admin) (define/public (set-draw-arrow-heads? x) @@ -248,6 +250,8 @@ (unbox wb) (unbox hb)))))) + + (define arrowhead-angle-width (* 1/4 pi)) (define arrowhead-short-side 8) (define arrowhead-long-side 12) @@ -484,7 +488,12 @@ (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (when before? - (draw-edges dc left top right bottom dx dy)) + (let ([old-font (send dc get-font)]) + (when edge-label-font + (send dc set-font edge-label-font)) + (draw-edges dc left top right bottom dx dy) + (when edge-label-font + (send dc set-font old-font)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) (define/public (draw-edges dc left top right bottom dx dy) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl index d74956f9a7..09bdd124b2 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl @@ -3,5 +3,13 @@ @defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{ +@defconstructor/auto-super[([edge-label-font (or/c #f (is-a?/c font%)) #f])]{ + +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 +the labels, defaulting to the @scheme[dc<%>] object's font. + +} + This mixin overrides many methods to draw lines between @scheme[graph-snip<%>] that it contains.} diff --git a/collects/redex/gui.ss b/collects/redex/gui.ss index 4049673df4..4983c60e21 100644 --- a/collects/redex/gui.ss +++ b/collects/redex/gui.ss @@ -35,7 +35,8 @@ #:pp pp-contract #:colors (listof (list/c string? string?)) #:scheme-colors? boolean? - #:layout (-> any/c any/c)) + #:layout (-> any/c any/c) + #:edge-label-font (or/c #f (is-a?/c font%))) any)] [traces/ps (->* (reduction-relation? any/c @@ -46,7 +47,8 @@ (any/c term-node? . -> . any)) #:pp pp-contract #:colors (listof any/c) - #:layout (-> any/c any/c)) + #:layout (-> any/c any/c) + #:edge-label-font (or/c #f (is-a?/c font%))) any)] [term-node? (-> any/c boolean?)] diff --git a/collects/redex/private/traces.ss b/collects/redex/private/traces.ss index 4098ff0f78..57befd42bf 100644 --- a/collects/redex/private/traces.ss +++ b/collects/redex/private/traces.ss @@ -131,7 +131,9 @@ #:pp [pp default-pretty-printer] #:scheme-colors? [scheme-colors? #t] #:colors [colors '()] - #:layout [layout void]) + #:layout [layout void] + #:edge-label-font [edge-label-font #f] + ) (let-values ([(graph-pb canvas) (traces reductions pre-exprs #:no-show-frame? #t @@ -140,7 +142,8 @@ #:pp pp #:scheme-colors? scheme-colors? #:colors colors - #:layout layout)]) + #:layout layout + #:edge-label-font edge-label-font)]) (print-to-ps graph-pb canvas filename))) (define (print-to-ps graph-pb canvas filename) @@ -227,11 +230,12 @@ #:colors [colors '()] #:scheme-colors? [scheme-colors? #t] #:layout [layout void] + #:edge-label-font [edge-label-font #f] #: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])) + (define graph-pb (new graph-pasteboard% [layout layout] [edge-label-font edge-label-font])) (define f (instantiate red-sem-frame% () (label "PLT Redex Reduction Graph") (style '(toolbar-button)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index b02ee88aef..1b35f0eafd 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1157,7 +1157,8 @@ exploring reduction sequences. (lambda (x) (member (length x) '(2 3 4 6))))))] [#:scheme-colors? scheme-colors? boolean?] - [#:layout layout (-> (listof term-node?) void)]) + [#:layout layout (-> (listof term-node?) void)] + [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]) void?]{ This function opens a new window and inserts each expression @@ -1169,7 +1170,7 @@ found, or no more reductions can occur. It inserts each new term into the gui. Clicking the @onscreen{reduce} button reduces until reduction-steps-cutoff more terms are found. -The pred function indicates if a term has a particular +The @scheme[pred] function indicates if a term has a particular property. If it returns @scheme[#f], the term is displayed with a pink background. If it returns a string or a @scheme[color%] object, the term is displayed with a background of that color (using @@ -1211,8 +1212,6 @@ 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], @@ -1224,8 +1223,10 @@ 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!]. -You can save the contents of the window as a postscript file -from the menus. +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 +font is used. + } @defproc[(traces/ps [reductions reduction-relation?] @@ -1241,7 +1242,8 @@ from the menus. (any output-port number (is-a?/c text%) -> void)) default-pretty-printer] [#:colors colors (listof (list string string)) '()] - [#:layout layout (-> (listof term-node?) void)]) + [#:layout layout (-> (listof term-node?) void)] + [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]) void?]{ The arguments behave just like the function @scheme[traces], but