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

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

@ -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

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

@ -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)

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))))
(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))

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

@ -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)))
))

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 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)

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 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)