suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move point label `radius' units from point; plug plot->dc API leak

Browse Source
This commit is contained in:
Neil Toronto 2011-11-21 00:50:01 -07:00
parent a333b43259
commit 94373ea9f9
6 changed files with 72 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/plot/common/draw.rkt
View File

@ -14,38 +14,46 @@
;; =================================================================================================== ;; ===================================================================================================
;; Drawing text rotated around an anchor point ;; 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 sin45 (/ 1 (sqrt 2)))
(define-values (width height _1 _2) (send dc get-text-extent str #f combine? offset))
(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 (define dx (case anchor
[(top-left left bottom-left) 0] [(top-left left bottom-left) (- dist)]
[(top center bottom) (* 1/2 width)] [(top center bottom) (* 1/2 width)]
[(top-right right bottom-right) width] [(top-right right bottom-right) (+ width dist)]
[else (raise-type-error 'draw-text/anchor "anchor/c" anchor)])) [else (raise-type-error 'draw-text/anchor "anchor/c" anchor)]))
(define dy (case anchor (define dy (case anchor
[(top-left top top-right) 0] [(top-left top top-right) (- dist)]
[(left center right) (* 1/2 height)] [(left center right) (* 1/2 height)]
[(bottom-left bottom bottom-right) height])) [(bottom-left bottom bottom-right) (+ height dist)]))
(define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) (define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
(define rdy (- (* (cos angle) dy) (* (sin angle) dx))) (define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
(send dc draw-text str (- x rdx) (- y rdy) combine? offset angle)) (send dc draw-text str (- x rdx) (- y rdy) #t 0 angle)))
(define (get-text-corners/anchor dc str x y [anchor 'top-left] [combine? #f] [offset 0] [angle 0]) (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 combine? offset)) (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 (define dxs (case anchor
[(top-left left bottom-left) (list 0 width)] [(top-left left bottom-left) (list (- dist) (- width dist))]
[(top center bottom) (list (* -1/2 width) (* 1/2 width))] [(top center bottom) (list (* -1/2 width) (* 1/2 width))]
[(top-right right bottom-right) (list (- width) 0)] [(top-right right bottom-right) (list (- dist width) dist)]
[else (raise-type-error 'get-text-corners/anchor "anchor/c" anchor)])) [else (raise-type-error 'get-text-corners/anchor "anchor/c" anchor)]))
(define dys (case anchor (define dys (case anchor
[(top-left top top-right) (list 0 height)] [(top-left top top-right) (list (- dist) (- height dist))]
[(left center right) (list (* -1/2 height) (* 1/2 width))] [(left center right) (list (* -1/2 height) (* 1/2 width))]
[(bottom-left bottom bottom-right) (list (- height) 0)])) [(bottom-left bottom bottom-right) (list (- dist height) dist)]))
(for*/list ([dx (in-list dxs)] [dy (in-list dys)]) (for*/list ([dx (in-list dxs)] [dy (in-list dys)])
(define rdx (+ (* (sin angle) dy) (* (cos angle) dx))) (define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
(define rdy (- (* (cos angle) dy) (* (sin angle) dx))) (define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
(vector (+ x rdx) (+ y rdy)))) (vector (+ x rdx) (+ y rdy)))))
;; =================================================================================================== ;; ===================================================================================================
;; Draw paramter normalization ;; Draw paramter normalization

10
collects/plot/common/plot-device.rkt
View File

@ -289,7 +289,7 @@
(match-define (vector x2 y2) v2) (match-define (vector x2 y2) v2)
(draw-line/pen-style dc x1 y1 x2 y2 pen-style))) (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) (when (vrational? v)
(match-define (vector x y) v) (match-define (vector x y) v)
@ -302,17 +302,17 @@
(for* ([dx (list -1 0 1)] (for* ([dx (list -1 0 1)]
[dy (list -1 0 1)] [dy (list -1 0 1)]
#:when (not (and (zero? dx) (zero? dy)))) #: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-alpha alpha)
(send dc set-text-foreground fg)) (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) (cond [(vrational? v)
(match-define (vector x y) v) (match-define (vector x y) v)
(map (λ (v) (vector-map inexact->exact 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])) [else empty]))
(define/public (draw-arrow v1 v2) (define/public (draw-arrow v1 v2)

18
collects/plot/plot2d/decoration.rkt
View File

@ -31,13 +31,10 @@
(send area put-tick (vector x y) (if major? radius (* 1/2 radius)) (* 1/2 pi)))) (send area put-tick (vector x y) (if major? radius (* 1/2 radius)) (* 1/2 pi))))
(when labels? (when labels?
(define pd (send area get-plot-device)) (define dist (+ radius (pen-gap)))
(define offset (vector 0 (+ radius (pen-gap))))
(for ([t (in-list x-ticks)] #:when (pre-tick-major? t)) (for ([t (in-list x-ticks)] #:when (pre-tick-major? t))
(match-define (tick x _ label) t) (match-define (tick x _ label) t)
(send pd draw-text label (send area put-text label (vector x y) (if far? 'bottom 'top) 0 dist)))
((if far? v- v+) (send area plot->dc (vector x y)) offset)
(if far? 'bottom 'top) 0)))
empty) empty)
@ -64,13 +61,10 @@
(send area put-tick (vector x y) (if major? radius (* 1/2 radius)) 0))) (send area put-tick (vector x y) (if major? radius (* 1/2 radius)) 0)))
(when labels? (when labels?
(define pd (send area get-plot-device)) (define dist (+ radius (pen-gap)))
(define offset (vector (+ radius (pen-gap)) 0))
(for ([t (in-list y-ticks)] #:when (pre-tick-major? t)) (for ([t (in-list y-ticks)] #:when (pre-tick-major? t))
(match-define (tick y _ label) t) (match-define (tick y _ label) t)
(send pd draw-text label (send area put-text label (vector x y) (if far? 'left 'right) 0 dist)))
((if far? v+ v-) (send area plot->dc (vector x y)) offset)
(if far? 'left 'right) 0)))
empty) empty)
@ -140,7 +134,7 @@
(match-define (tick r major? label) t) (match-define (tick r major? label) t)
(when (and major? (<= mr-min r mr-max)) (when (and major? (<= mr-min r mr-max))
(send area put-text label (vector (* r (cos mθ)) (* r (sin mθ))) (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) (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)) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) (send area get-bounds-rect))
@ -221,7 +215,7 @@
; label ; label
(send area put-text-foreground color) (send area put-text-foreground color)
(send area put-font size family) (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 ; point
(send area put-pen color 1 'solid) (send area put-pen color 1 'solid)
(send area put-glyphs (list v) 'fullcircle point-size)) (send area put-glyphs (list v) 'fullcircle point-size))

41
collects/plot/plot2d/plot-area.rkt
View File

@ -92,8 +92,7 @@
(vector (fx x) (fy y))))])) (vector (fx x) (fy y))))]))
(define view->dc #f) (define view->dc #f)
(define (plot->dc* v) (view->dc (plot->view v))) (define (plot->dc v) (view->dc (plot->view v)))
(define/public (plot->dc v) (plot->dc* v))
(define-values (view-x-size view-y-size) (define-values (view-x-size view-y-size)
(match-let ([(vector view-x-ivl view-y-ivl) (match-let ([(vector view-x-ivl view-y-ivl)
@ -125,7 +124,7 @@
(define near-dist^2 (sqr (* 3 (plot-line-width)))) (define near-dist^2 (sqr (* 3 (plot-line-width))))
(define (vnear? v1 v2) (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) (define ((x-tick-near? y) t1 t2)
(vnear? (vector (pre-tick-value t1) y) (vnear? (vector (pre-tick-value t1) y)
@ -159,11 +158,11 @@
;; ----------------------------------------------------------------------------------------------- ;; -----------------------------------------------------------------------------------------------
;; Tick parameters ;; Tick parameters
(define (x-tick-value->dc x) (plot->dc* (vector x y-min))) (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 (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 (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 (y-far-tick-value->dc y) (plot->dc (vector x-max y)))
(define (get-tick-params ticks tick-value->dc angle) (define (get-tick-params ticks tick-value->dc angle)
(for/list ([t (in-list ticks)]) (for/list ([t (in-list ticks)])
@ -377,8 +376,6 @@
;; =============================================================================================== ;; ===============================================================================================
;; Public drawing interface (used by renderers) ;; 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-alpha alpha) (send pd set-alpha alpha))
(define/public (put-pen color width style) (send pd set-pen color width style)) (define/public (put-pen color width style) (send pd set-pen color width style))
@ -411,8 +408,8 @@
clip-y-min clip-y-max)) clip-y-min clip-y-max))
(in-value vs))]) (in-value vs))])
(when (not (empty? vs)) (when (not (empty? vs))
(let ([vs (if identity-transforms? vs (subdivide-lines plot->dc* vs))]) (let ([vs (if identity-transforms? vs (subdivide-lines plot->dc vs))])
(send pd draw-lines (map (λ (v) (plot->dc* v)) vs))))))) (send pd draw-lines (map (λ (v) (plot->dc v)) vs)))))))
(define/public (put-line v1 v2) (define/public (put-line v1 v2)
(when (and (vrational? v1) (vrational? v2)) (when (and (vrational? v1) (vrational? v2))
@ -422,9 +419,9 @@
(values v1 v2))]) (values v1 v2))])
(when (and v1 v2) (when (and v1 v2)
(if identity-transforms? (if identity-transforms?
(send pd draw-line (plot->dc* v1) (plot->dc* v2)) (send pd draw-line (plot->dc v1) (plot->dc v2))
(send pd draw-lines (map (λ (v) (plot->dc* v)) (send pd draw-lines (map (λ (v) (plot->dc v))
(subdivide-line plot->dc* v1 v2)))))))) (subdivide-line plot->dc v1 v2))))))))
(define/public (put-polygon vs) (define/public (put-polygon vs)
(when (andmap vrational? vs) (when (andmap vrational? vs)
@ -434,31 +431,31 @@
vs)]) vs)])
(when (not (empty? vs)) (when (not (empty? vs))
(if identity-transforms? (if identity-transforms?
(send pd draw-polygon (map (λ (v) (plot->dc* v)) vs)) (send pd draw-polygon (map (λ (v) (plot->dc v)) vs))
(send pd draw-polygon (map (λ (v) (plot->dc* v)) (send pd draw-polygon (map (λ (v) (plot->dc v))
(subdivide-polygon plot->dc* vs)))))))) (subdivide-polygon plot->dc vs))))))))
(define/public (put-rect r) (define/public (put-rect r)
(when (rect-rational? r) (when (rect-rational? r)
(match-define (vector (ivl x1 x2) (ivl y1 y2)) 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))))) (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]) #:outline? [outline? #f])
(when (and (vrational? v) (in-bounds? v)) (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) (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))) (filter (λ (v) (and (vrational? v) (in-bounds? v)))
vs)) vs))
symbol size)) symbol size))
(define/public (put-arrow v1 v2) (define/public (put-arrow v1 v2)
(when (and (vrational? v1) (vrational? v2) (in-bounds? v1)) (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) (define/public (put-tick v r angle)
(when (and (vrational? v) (in-bounds? v)) (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)))
)) ))

10
collects/plot/plot3d/plot-area.rkt
View File

@ -648,10 +648,10 @@
(send pd set-pen pen-color pen-width pen-style) (send pd set-pen pen-color pen-width pen-style)
(send pd draw-line (norm->dc v1) (norm->dc v2))] (send pd draw-line (norm->dc v1) (norm->dc v2))]
;; text ;; 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-font font-size font-family)
(send pd set-text-foreground color) (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
[(glyph alpha _ symbol size pen-color pen-width pen-style brush-color brush-style) [(glyph alpha _ symbol size pen-color pen-width pen-style brush-color brush-style)
(send pd set-pen pen-color pen-width pen-style) (send pd set-pen pen-color pen-width pen-style)
@ -738,8 +738,6 @@
;; =============================================================================================== ;; ===============================================================================================
;; Public drawing interface (used by renderers) ;; Public drawing interface (used by renderers)
(define/public (get-plot-device) pd)
(define/public (get-render-list) render-list) (define/public (get-render-list) render-list)
(define/public (put-render-list shapes) (add-shapes! shapes)) (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)) (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)))))) 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)) (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)))) font-size font-family text-foreground))))
(define/public (put-glyphs vs symbol size) (define/public (put-glyphs vs symbol size)

2
collects/plot/plot3d/shape.rkt
View File

@ -10,7 +10,7 @@
(struct polygon shape (vs normal pen-color pen-width pen-style brush-color brush-style) #:transparent) (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 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 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 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 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) (struct arrow-glyph shape (start end pen-color pen-width pen-style) #:transparent)