diff --git a/collects/plot/common/draw.rkt b/collects/plot/common/draw.rkt index 2f75da637c..3432d9b679 100644 --- a/collects/plot/common/draw.rkt +++ b/collects/plot/common/draw.rkt @@ -14,38 +14,46 @@ ;; =================================================================================================== ;; Drawing text rotated around an anchor point -(define (draw-text/anchor dc str x y [anchor 'top-left] [combine? #f] [offset 0] [angle 0]) - (define-values (width height _1 _2) (send dc get-text-extent str #f combine? offset)) - (define dx (case anchor - [(top-left left bottom-left) 0] - [(top center bottom) (* 1/2 width)] - [(top-right right bottom-right) width] - [else (raise-type-error 'draw-text/anchor "anchor/c" anchor)])) - (define dy (case anchor - [(top-left top top-right) 0] - [(left center right) (* 1/2 height)] - [(bottom-left bottom bottom-right) height])) - (define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) - (define rdy (- (* (cos angle) dy) (* (sin angle) dx))) - - (send dc draw-text str (- x rdx) (- y rdy) combine? offset angle)) +(define sin45 (/ 1 (sqrt 2))) -(define (get-text-corners/anchor dc str x y [anchor 'top-left] [combine? #f] [offset 0] [angle 0]) - (define-values (width height _1 _2) (send dc get-text-extent str #f combine? offset)) - (define dxs (case anchor - [(top-left left bottom-left) (list 0 width)] - [(top center bottom) (list (* -1/2 width) (* 1/2 width))] - [(top-right right bottom-right) (list (- width) 0)] - [else (raise-type-error 'get-text-corners/anchor "anchor/c" anchor)])) - (define dys (case anchor - [(top-left top top-right) (list 0 height)] - [(left center right) (list (* -1/2 height) (* 1/2 width))] - [(bottom-left bottom bottom-right) (list (- height) 0)])) - - (for*/list ([dx (in-list dxs)] [dy (in-list dys)]) +(define (draw-text/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0]) + (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0)) + (let ([dist (case anchor + [(top-left bottom-left top-right bottom-right) (* sin45 dist)] + [else dist])]) + (define dx (case anchor + [(top-left left bottom-left) (- dist)] + [(top center bottom) (* 1/2 width)] + [(top-right right bottom-right) (+ width dist)] + [else (raise-type-error 'draw-text/anchor "anchor/c" anchor)])) + (define dy (case anchor + [(top-left top top-right) (- dist)] + [(left center right) (* 1/2 height)] + [(bottom-left bottom bottom-right) (+ height dist)])) (define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) (define rdy (- (* (cos angle) dy) (* (sin angle) dx))) - (vector (+ x rdx) (+ y rdy)))) + + (send dc draw-text str (- x rdx) (- y rdy) #t 0 angle))) + +(define (get-text-corners/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0]) + (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0)) + (let ([dist (case anchor + [(top-left bottom-left top-right bottom-right) (* sin45 dist)] + [else dist])]) + (define dxs (case anchor + [(top-left left bottom-left) (list (- dist) (- width dist))] + [(top center bottom) (list (* -1/2 width) (* 1/2 width))] + [(top-right right bottom-right) (list (- dist width) dist)] + [else (raise-type-error 'get-text-corners/anchor "anchor/c" anchor)])) + (define dys (case anchor + [(top-left top top-right) (list (- dist) (- height dist))] + [(left center right) (list (* -1/2 height) (* 1/2 width))] + [(bottom-left bottom bottom-right) (list (- dist height) dist)])) + + (for*/list ([dx (in-list dxs)] [dy (in-list dys)]) + (define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) + (define rdy (- (* (cos angle) dy) (* (sin angle) dx))) + (vector (+ x rdx) (+ y rdy))))) ;; =================================================================================================== ;; Draw paramter normalization diff --git a/collects/plot/common/plot-device.rkt b/collects/plot/common/plot-device.rkt index e13ac61a29..3c5c82e2c7 100644 --- a/collects/plot/common/plot-device.rkt +++ b/collects/plot/common/plot-device.rkt @@ -289,7 +289,7 @@ (match-define (vector x2 y2) v2) (draw-line/pen-style dc x1 y1 x2 y2 pen-style))) - (define/public (draw-text str v [anchor 'top-left] [angle 0] #:outline? [outline? #f]) + (define/public (draw-text str v [anchor 'top-left] [angle 0] [dist 0] #:outline? [outline? #f]) (when (vrational? v) (match-define (vector x y) v) @@ -302,17 +302,17 @@ (for* ([dx (list -1 0 1)] [dy (list -1 0 1)] #:when (not (and (zero? dx) (zero? dy)))) - (draw-text/anchor dc str (+ x dx) (+ y dy) anchor #t 0 angle)) + (draw-text/anchor dc str (+ x dx) (+ y dy) anchor angle dist)) ;(send dc set-alpha alpha) (send dc set-text-foreground fg)) - (draw-text/anchor dc str x y anchor #t 0 angle))) + (draw-text/anchor dc str x y anchor angle dist))) - (define/public (get-text-corners str v [anchor 'top-left] [angle 0]) + (define/public (get-text-corners str v [anchor 'top-left] [angle 0] [dist 0]) (cond [(vrational? v) (match-define (vector x y) v) (map (λ (v) (vector-map inexact->exact v)) - (get-text-corners/anchor dc str x y anchor #t 0 angle))] + (get-text-corners/anchor dc str x y anchor angle dist))] [else empty])) (define/public (draw-arrow v1 v2) diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index b5220d0dec..a05d06428d 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -31,13 +31,10 @@ (send area put-tick (vector x y) (if major? radius (* 1/2 radius)) (* 1/2 pi)))) (when labels? - (define pd (send area get-plot-device)) - (define offset (vector 0 (+ radius (pen-gap)))) + (define dist (+ radius (pen-gap))) (for ([t (in-list x-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (send pd draw-text label - ((if far? v- v+) (send area plot->dc (vector x y)) offset) - (if far? 'bottom 'top) 0))) + (send area put-text label (vector x y) (if far? 'bottom 'top) 0 dist))) empty) @@ -64,13 +61,10 @@ (send area put-tick (vector x y) (if major? radius (* 1/2 radius)) 0))) (when labels? - (define pd (send area get-plot-device)) - (define offset (vector (+ radius (pen-gap)) 0)) + (define dist (+ radius (pen-gap))) (for ([t (in-list y-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (send pd draw-text label - ((if far? v+ v-) (send area plot->dc (vector x y)) offset) - (if far? 'left 'right) 0))) + (send area put-text label (vector x y) (if far? 'left 'right) 0 dist))) empty) @@ -140,7 +134,7 @@ (match-define (tick r major? label) t) (when (and major? (<= mr-min r mr-max)) (send area put-text label (vector (* r (cos mθ)) (* r (sin mθ))) - 'center 0 #:outline? #t))))) + 'center #:outline? #t))))) (define (draw-polar-axis-lines num area) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect)) @@ -221,7 +215,7 @@ ; label (send area put-text-foreground color) (send area put-font size family) - (send area put-text (string-append " " label " ") v anchor angle #:outline? #t) + (send area put-text (string-append " " label " ") v anchor angle (* 1/2 point-size) #:outline? #t) ; point (send area put-pen color 1 'solid) (send area put-glyphs (list v) 'fullcircle point-size)) diff --git a/collects/plot/plot2d/plot-area.rkt b/collects/plot/plot2d/plot-area.rkt index 560c784380..08c1474d32 100644 --- a/collects/plot/plot2d/plot-area.rkt +++ b/collects/plot/plot2d/plot-area.rkt @@ -92,8 +92,7 @@ (vector (fx x) (fy y))))])) (define view->dc #f) - (define (plot->dc* v) (view->dc (plot->view v))) - (define/public (plot->dc v) (plot->dc* v)) + (define (plot->dc v) (view->dc (plot->view v))) (define-values (view-x-size view-y-size) (match-let ([(vector view-x-ivl view-y-ivl) @@ -125,7 +124,7 @@ (define near-dist^2 (sqr (* 3 (plot-line-width)))) (define (vnear? v1 v2) - ((vmag^2 (v- (plot->dc* v1) (plot->dc* v2))) . <= . near-dist^2)) + ((vmag^2 (v- (plot->dc v1) (plot->dc v2))) . <= . near-dist^2)) (define ((x-tick-near? y) t1 t2) (vnear? (vector (pre-tick-value t1) y) @@ -159,11 +158,11 @@ ;; ----------------------------------------------------------------------------------------------- ;; Tick parameters - (define (x-tick-value->dc x) (plot->dc* (vector x y-min))) - (define (y-tick-value->dc y) (plot->dc* (vector x-min y))) + (define (x-tick-value->dc x) (plot->dc (vector x y-min))) + (define (y-tick-value->dc y) (plot->dc (vector x-min y))) - (define (x-far-tick-value->dc x) (plot->dc* (vector x y-max))) - (define (y-far-tick-value->dc y) (plot->dc* (vector x-max y))) + (define (x-far-tick-value->dc x) (plot->dc (vector x y-max))) + (define (y-far-tick-value->dc y) (plot->dc (vector x-max y))) (define (get-tick-params ticks tick-value->dc angle) (for/list ([t (in-list ticks)]) @@ -377,8 +376,6 @@ ;; =============================================================================================== ;; Public drawing interface (used by renderers) - (define/public (get-plot-device) pd) - (define/public (put-alpha alpha) (send pd set-alpha alpha)) (define/public (put-pen color width style) (send pd set-pen color width style)) @@ -411,8 +408,8 @@ clip-y-min clip-y-max)) (in-value vs))]) (when (not (empty? vs)) - (let ([vs (if identity-transforms? vs (subdivide-lines plot->dc* vs))]) - (send pd draw-lines (map (λ (v) (plot->dc* v)) vs))))))) + (let ([vs (if identity-transforms? vs (subdivide-lines plot->dc vs))]) + (send pd draw-lines (map (λ (v) (plot->dc v)) vs))))))) (define/public (put-line v1 v2) (when (and (vrational? v1) (vrational? v2)) @@ -422,9 +419,9 @@ (values v1 v2))]) (when (and v1 v2) (if identity-transforms? - (send pd draw-line (plot->dc* v1) (plot->dc* v2)) - (send pd draw-lines (map (λ (v) (plot->dc* v)) - (subdivide-line plot->dc* v1 v2)))))))) + (send pd draw-line (plot->dc v1) (plot->dc v2)) + (send pd draw-lines (map (λ (v) (plot->dc v)) + (subdivide-line plot->dc v1 v2)))))))) (define/public (put-polygon vs) (when (andmap vrational? vs) @@ -434,31 +431,31 @@ vs)]) (when (not (empty? vs)) (if identity-transforms? - (send pd draw-polygon (map (λ (v) (plot->dc* v)) vs)) - (send pd draw-polygon (map (λ (v) (plot->dc* v)) - (subdivide-polygon plot->dc* vs)))))))) + (send pd draw-polygon (map (λ (v) (plot->dc v)) vs)) + (send pd draw-polygon (map (λ (v) (plot->dc v)) + (subdivide-polygon plot->dc vs)))))))) (define/public (put-rect r) (when (rect-rational? r) (match-define (vector (ivl x1 x2) (ivl y1 y2)) r) (put-polygon (list (vector x1 y1) (vector x2 y1) (vector x2 y2) (vector x1 y2))))) - (define/public (put-text str v [anchor 'top-left] [angle 0] + (define/public (put-text str v [anchor 'top-left] [angle 0] [dist 0] #:outline? [outline? #f]) (when (and (vrational? v) (in-bounds? v)) - (send pd draw-text str (plot->dc* v) anchor angle #:outline? outline?))) + (send pd draw-text str (plot->dc v) anchor angle dist #:outline? outline?))) (define/public (put-glyphs vs symbol size) - (send pd draw-glyphs (map (λ (v) (plot->dc* v)) + (send pd draw-glyphs (map (λ (v) (plot->dc v)) (filter (λ (v) (and (vrational? v) (in-bounds? v))) vs)) symbol size)) (define/public (put-arrow v1 v2) (when (and (vrational? v1) (vrational? v2) (in-bounds? v1)) - (send pd draw-arrow (plot->dc* v1) (plot->dc* v2)))) + (send pd draw-arrow (plot->dc v1) (plot->dc v2)))) (define/public (put-tick v r angle) (when (and (vrational? v) (in-bounds? v)) - (send pd draw-tick (plot->dc* v) r angle))) + (send pd draw-tick (plot->dc v) r angle))) )) diff --git a/collects/plot/plot3d/plot-area.rkt b/collects/plot/plot3d/plot-area.rkt index fd13bd0125..da98a79566 100644 --- a/collects/plot/plot3d/plot-area.rkt +++ b/collects/plot/plot3d/plot-area.rkt @@ -648,10 +648,10 @@ (send pd set-pen pen-color pen-width pen-style) (send pd draw-line (norm->dc v1) (norm->dc v2))] ;; text - [(text alpha _ anchor angle str font-size font-family color) + [(text alpha _ anchor angle dist str font-size font-family color) (send pd set-font font-size font-family) (send pd set-text-foreground color) - (send pd draw-text str (view->dc center) anchor angle)] + (send pd draw-text str (view->dc center) anchor angle dist)] ;; glyph [(glyph alpha _ symbol size pen-color pen-width pen-style brush-color brush-style) (send pd set-pen pen-color pen-width pen-style) @@ -738,8 +738,6 @@ ;; =============================================================================================== ;; Public drawing interface (used by renderers) - (define/public (get-plot-device) pd) - (define/public (get-render-list) render-list) (define/public (put-render-list shapes) (add-shapes! shapes)) @@ -862,9 +860,9 @@ (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) pen-color pen-width pen-style brush-color brush-style)))))) - (define/public (put-text str v [anchor 'center] [angle 0]) + (define/public (put-text str v [anchor 'center] [angle 0] [dist 0]) (when (and (vrational? v) (in-bounds? v)) - (add-shape! (text alpha (plot->norm v) anchor angle str + (add-shape! (text alpha (plot->norm v) anchor angle dist str font-size font-family text-foreground)))) (define/public (put-glyphs vs symbol size) diff --git a/collects/plot/plot3d/shape.rkt b/collects/plot/plot3d/shape.rkt index cff5307d88..ca2a68f773 100644 --- a/collects/plot/plot3d/shape.rkt +++ b/collects/plot/plot3d/shape.rkt @@ -10,7 +10,7 @@ (struct polygon shape (vs normal pen-color pen-width pen-style brush-color brush-style) #:transparent) (struct rectangle shape (rect pen-color pen-width pen-style brush-color brush-style) #:transparent) (struct line shape (v1 v2 pen-color pen-width pen-style) #:transparent) -(struct text shape (anchor angle str font-size font-family color) #:transparent) +(struct text shape (anchor angle dist str font-size font-family color) #:transparent) (struct glyph shape (symbol size pen-color pen-width pen-style brush-color brush-style) #:transparent) (struct tick-glyph shape (radius angle pen-color pen-width pen-style) #:transparent) (struct arrow-glyph shape (start end pen-color pen-width pen-style) #:transparent)