diff --git a/collects/plot/common/draw.rkt b/collects/plot/common/draw.rkt index 5450434b9c..11d340c9ea 100644 --- a/collects/plot/common/draw.rkt +++ b/collects/plot/common/draw.rkt @@ -236,3 +236,43 @@ [xs (listof any/c)]) (listof any/c) (cond [(procedure? list-or-proc) (list-or-proc xs)] [else list-or-proc])) + +;; =================================================================================================== +;; Subdividing nonlinearly transformed shapes + +(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7)) + +(define (subdivide-line transform v1 v2) + (let loop ([v1 v1] [v2 v2] [depth 10]) + (let/ec return + (when (zero? depth) (return (list v1 v2))) + + (define dc-v1 (transform v1)) + (define dc-v2 (transform v2)) + (define dc-dv (v- dc-v2 dc-v1)) + (when ((vmag dc-dv) . <= . 3) + (return (list v1 v2))) + + (define dv (v- v2 v1)) + (define-values (max-area vc) + (for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)]) + (define test-vc (v+ (v* dv frac) v1)) + (define test-area (abs (vcross2 dc-dv (v- (transform test-vc) dc-v1)))) + (cond [(test-area . > . max-area) (values test-area test-vc)] + [else (values max-area vc)]))) + (when (max-area . <= . 3) (return (list v1 v2))) + + ;(plot3d-subdivisions (+ (plot3d-subdivisions) 1)) + (append (loop v1 vc (- depth 1)) + (rest (loop vc v2 (- depth 1))))))) + +(define (subdivide-lines transform vs) + (append + (append* + (for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))]) + (define line-vs (subdivide-line transform v1 v2)) + (take line-vs (sub1 (length line-vs))))) + (list (last vs)))) + +(define (subdivide-polygon transform vs) + (subdivide-lines transform (cons (last vs) vs))) diff --git a/collects/plot/common/legend.rkt b/collects/plot/common/legend.rkt index 444b14e0db..cbb41ba819 100644 --- a/collects/plot/common/legend.rkt +++ b/collects/plot/common/legend.rkt @@ -19,11 +19,11 @@ (defproc (line-legend-entry [label string?] [color plot-color/c] [width (>=/c 0)] [style plot-pen-style/c] ) legend-entry? - (legend-entry label (λ (plot-area x-min x-max y-min y-max) + (legend-entry label (λ (pd x-min x-max y-min y-max) (define y (* 1/2 (+ y-min y-max))) - (send plot-area set-pen color width style) - (send plot-area set-alpha 1) - (send plot-area draw-line (vector x-min y) (vector x-max y))))) + (send pd set-pen color width style) + (send pd set-alpha 1) + (send pd draw-line (vector x-min y) (vector x-max y))))) (defproc (line-legend-entries [label string?] [zs (listof real?)] [z-labels (listof string?)] [colors plot-colors/c] [widths pen-widths/c] [styles plot-pen-styles/c] @@ -51,11 +51,11 @@ [fill-color plot-color/c] [fill-style plot-brush-style/c] [line-color plot-color/c] [line-width (>=/c 0)] [line-style plot-pen-style/c]) legend-entry? - (legend-entry label (λ (plot-area x-min x-max y-min y-max) - (send plot-area set-brush fill-color fill-style) - (send plot-area set-pen line-color line-width line-style) - (send plot-area set-alpha 1) - (send plot-area draw-rectangle (vector x-min y-min) (vector x-max y-max))))) + (legend-entry label (λ (pd x-min x-max y-min y-max) + (send pd set-brush fill-color fill-style) + (send pd set-pen line-color line-width line-style) + (send pd set-alpha 1) + (send pd draw-rectangle (vector x-min y-min) (vector x-max y-max))))) (defproc (rectangle-legend-entries [label string?] [zs (listof real?)] [fill-colors plot-colors/c] [fill-styles plot-brush-styles/c] @@ -92,18 +92,18 @@ [line1-color plot-color/c] [line1-width (>=/c 0)] [line1-style plot-pen-style/c] [line2-color plot-color/c] [line2-width (>=/c 0)] [line2-style plot-pen-style/c] ) legend-entry? - (legend-entry label (λ (plot-area x-min x-max y-min y-max) - (send plot-area set-alpha 1) + (legend-entry label (λ (pd x-min x-max y-min y-max) + (send pd set-alpha 1) ;; rectangle - (send plot-area set-pen line-color line-width line-style) - (send plot-area set-brush fill-color fill-style) - (send plot-area draw-rectangle (vector x-min y-min) (vector x-max y-max)) + (send pd set-pen line-color line-width line-style) + (send pd set-brush fill-color fill-style) + (send pd draw-rectangle (vector x-min y-min) (vector x-max y-max)) ;; bottom line - (send plot-area set-pen line1-color line1-width line1-style) - (send plot-area draw-line (vector x-min y-max) (vector x-max y-max)) + (send pd set-pen line1-color line1-width line1-style) + (send pd draw-line (vector x-min y-max) (vector x-max y-max)) ;; top line - (send plot-area set-pen line2-color line2-width line2-style) - (send plot-area draw-line (vector x-min y-min) (vector x-max y-min))))) + (send pd set-pen line2-color line2-width line2-style) + (send pd draw-line (vector x-min y-min) (vector x-max y-min))))) (defproc (interval-legend-entries [label string?] [zs (listof real?)] [z-labels (listof string?)] @@ -173,19 +173,19 @@ (defproc (point-legend-entry [label string?] [sym point-sym/c] [color plot-color/c] [size (>=/c 0)] [line-width (>=/c 0)]) legend-entry? - (legend-entry label (λ (plot-area x-min x-max y-min y-max) - (send plot-area set-pen color line-width 'solid) - (send plot-area set-alpha 1) - (send plot-area draw-glyphs + (legend-entry label (λ (pd x-min x-max y-min y-max) + (send pd set-pen color line-width 'solid) + (send pd set-alpha 1) + (send pd draw-glyphs (list (vector (* 1/2 (+ x-min x-max)) (* 1/2 (+ y-min y-max)))) sym size)))) (defproc (vector-field-legend-entry [label string?] [color plot-color/c] [line-width (>=/c 0)] [line-style plot-pen-style/c] ) legend-entry? - (legend-entry label (λ (plot-area x-min x-max y-min y-max) - (send plot-area set-pen color line-width line-style) - (send plot-area set-alpha 1) - (send plot-area draw-arrow-glyph + (legend-entry label (λ (pd x-min x-max y-min y-max) + (send pd set-pen color line-width line-style) + (send pd set-alpha 1) + (send pd draw-arrow-glyph (vector (* 1/2 (+ x-min x-max)) (* 1/2 (+ y-min y-max))) (* 1/4 (- x-max x-min)) 0)))) diff --git a/collects/plot/common/area.rkt b/collects/plot/common/plot-device.rkt similarity index 98% rename from collects/plot/common/area.rkt rename to collects/plot/common/plot-device.rkt index 6e5a653ad5..8a003948a5 100644 --- a/collects/plot/common/area.rkt +++ b/collects/plot/common/plot-device.rkt @@ -1,14 +1,10 @@ #lang racket/base -;; Defines the base class for 2d-plot-area% and 3d-plot-area%. - -;; Instances of this class know how to draw points, polygons, rectangles, lines, text, and a bunch of +;; Instances of this class know how to draw points, polygons, rectangles, lines, text, a bunch of ;; different "glyphs" (used for point symbols and ticks), and legends on their underlying device -;; contexts. +;; contexts. Drawing functions accept vectors representing dc coordinates. -;; Drawing functions accept vectors representing dc coordinates. It is up to descendants to provide -;; drawing functions that accept view coordinates and transform them into dc coordinates. By -;; convention, such functions start with "put-" instead of "draw-". +;; It is up to callers to transform view or plot coordinates into dc coordinates. (require racket/draw racket/class racket/match racket/math racket/bool racket/list racket/contract "contract.rkt" @@ -18,7 +14,7 @@ "parameters.rkt" "legend.rkt") -(provide plot-area%) +(provide plot-device%) (define (coord->cons v) (match-define (vector x y) v) @@ -152,7 +148,7 @@ try-color) (super-new))) -(define plot-area% +(define plot-device% (class object% (init-field dc dc-x-min dc-y-min dc-x-size dc-y-size) @@ -547,7 +543,7 @@ ;; =============================================================================================== ;; Legend - (define/public (draw-legend-box legend-entries x-min x-max y-min y-max) + (define/public (draw-legend legend-entries x-min x-max y-min y-max) (define n (length legend-entries)) (match-define (list (legend-entry labels draws) ...) legend-entries) diff --git a/collects/plot/compat.rkt b/collects/plot/compat.rkt index f4979e3889..9d3433d8e7 100644 --- a/collects/plot/compat.rkt +++ b/collects/plot/compat.rkt @@ -88,9 +88,12 @@ x-min x-max y-min y-max dc 0 0 width height)) + (define data+axes (mix x-axis-data y-axis-data data)) + (send area start-plot) (send area start-renderer x-min x-max y-min y-max) - ((mix x-axis-data y-axis-data data) area) + (data+axes area) + (send area end-renderers) (send area end-plot) (when out-file (send bm save-file out-file 'png)) @@ -135,6 +138,7 @@ (send area start-plot) (send area start-renderer x-min x-max y-min y-max z-min z-max) (data area) + (send area end-renderers) (send area end-plot) (when out-file (send bm save-file out-file 'png)) diff --git a/collects/plot/contracted/legend.rkt b/collects/plot/contracted/legend.rkt index e981f3fbf7..5ca7f2d6d3 100644 --- a/collects/plot/contracted/legend.rkt +++ b/collects/plot/contracted/legend.rkt @@ -3,10 +3,11 @@ (require racket/contract unstable/latent-contract racket/class) (require "../common/legend.rkt" - "../common/area.rkt") + "../common/plot-device.rkt") (provide (contract-out (struct legend-entry ([label string?] - [draw ((is-a?/c plot-area%) real? real? real? real? . -> . void?)]))) + [draw ((is-a?/c plot-device%) real? real? real? real? + . -> . void?)]))) (activate-contract-out line-legend-entry line-legend-entries rectangle-legend-entry rectangle-legend-entries diff --git a/collects/plot/plot2d/area.rkt b/collects/plot/plot2d/area.rkt index 82633198ba..7119511b55 100644 --- a/collects/plot/plot2d/area.rkt +++ b/collects/plot/plot2d/area.rkt @@ -1,10 +1,11 @@ #lang racket/base (require racket/draw racket/class racket/contract racket/match racket/math racket/list racket/string - "../common/area.rkt" + "../common/plot-device.rkt" "../common/ticks.rkt" "../common/contract.rkt" "../common/math.rkt" + "../common/draw.rkt" "../common/axis-transform.rkt" "../common/sample.rkt" "../common/legend.rkt" @@ -17,23 +18,16 @@ (define plot2d-subdivisions (make-parameter 0)) (define 2d-plot-area% - (class plot-area% + (class object% (init-field rx-ticks rx-far-ticks ry-ticks ry-far-ticks x-min x-max y-min y-max) (init dc dc-x-min dc-y-min dc-x-size dc-y-size) - (inherit - set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground - set-font restore-drawing-params reset-drawing-params - get-text-width get-text-extent get-char-height get-char-baseline - set-clipping-rect clear-clipping-rect - clear draw-polygon draw-rectangle draw-line draw-lines draw-text draw-glyphs draw-arrow - draw-tick draw-legend-box) + (super-new) - (super-make-object dc dc-x-min dc-y-min dc-x-size dc-y-size) + (define pd (make-object plot-device% dc dc-x-min dc-y-min dc-x-size dc-y-size)) + (send pd reset-drawing-params) - (reset-drawing-params) - - (define char-height (get-char-height)) + (define char-height (send pd get-char-height)) (define dc-x-max (+ dc-x-min dc-x-size)) (define dc-y-max (+ dc-y-min dc-y-size)) @@ -71,6 +65,11 @@ (define/public (clip-to-none) (set! clipping? #f)) + (define (in-bounds? v) + (or (not clipping?) + (point-in-bounds? v clip-x-min clip-x-max + clip-y-min clip-y-max))) + (define/public (get-x-ticks) x-ticks) (define/public (get-x-far-ticks) x-far-ticks) (define/public (get-y-ticks) y-ticks) @@ -99,10 +98,11 @@ (vector (fx x) (fy y))))])) (define view->dc #f) - (define/public (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/public (plot-line->dc-angle v1 v2) - (match-define (vector dx dy) (v- (plot->dc v1) (plot->dc v2))) + (match-define (vector dx dy) (v- (plot->dc* v1) (plot->dc* v2))) (- (atan2 (- dy) dx))) (define (make-view->dc left right top bottom) @@ -135,15 +135,17 @@ ;; =============================================================================================== ;; Tick and label constants + (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)) + (define ((x-tick-near? y) t1 t2) - ((vmag (v- (plot->dc (vector (pre-tick-value t1) y)) - (plot->dc (vector (pre-tick-value t2) y)))) - . <= . (* 3 (plot-line-width)))) + (vnear? (vector (pre-tick-value t1) y) + (vector (pre-tick-value t2) y))) (define ((y-tick-near? x) t1 t2) - ((vmag (v- (plot->dc (vector x (pre-tick-value t1))) - (plot->dc (vector x (pre-tick-value t2))))) - . <= . (* 3 (plot-line-width)))) + (vnear? (vector x (pre-tick-value t1)) + (vector x (pre-tick-value t2)))) (define x-ticks (collapse-nearby-ticks (filter (λ (t) (<= x-min (pre-tick-value t) x-max)) rx-ticks) @@ -176,7 +178,7 @@ (define (max-tick-label-width ts) (apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t)) - (get-text-width (tick-label t))))) + (send pd get-text-width (tick-label t))))) (define max-x-tick-label-height (if (plot-x-axis?) (max-tick-label-height x-ticks) 0)) (define max-y-tick-label-width (if (plot-y-axis?) (max-tick-label-width y-ticks) 0)) @@ -227,25 +229,25 @@ (define offset (vector 0 (+ (pen-gap) (* 1/2 (plot-tick-size))))) (for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (list label (v+ (plot->dc (vector x y-min)) offset) 'top))) + (list label (v+ (plot->dc* (vector x y-min)) offset) 'top))) (define (get-y-tick-label-params) (define offset (vector (+ (pen-gap) (* 1/2 (plot-tick-size))) 0)) (for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (list label (v- (plot->dc (vector x-min y)) offset) 'right))) + (list label (v- (plot->dc* (vector x-min y)) offset) 'right))) (define (get-x-far-tick-label-params) (define offset (vector 0 (+ (pen-gap) (* 1/2 (plot-tick-size))))) (for/list ([t (in-list x-far-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (list label (v- (plot->dc (vector x y-max)) offset) 'bottom))) + (list label (v- (plot->dc* (vector x y-max)) offset) 'bottom))) (define (get-y-far-tick-label-params) (define offset (vector (+ (pen-gap) (* 1/2 (plot-tick-size))) 0)) (for/list ([t (in-list y-far-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (list label (v+ (plot->dc (vector x-max y)) offset) 'left))) + (list label (v+ (plot->dc* (vector x-max y)) offset) 'left))) ;; =============================================================================================== ;; Tick parameters @@ -257,16 +259,16 @@ (append (for/list ([t (in-list (if (plot-x-axis?) x-ticks empty))]) (match-define (tick x major? _) t) - (list major? (plot->dc (vector x y-min)) (if major? radius 1/2radius) (* 1/2 pi))) + (list major? (plot->dc* (vector x y-min)) (if major? radius 1/2radius) (* 1/2 pi))) (for/list ([t (in-list (if (plot-y-axis?) y-ticks empty))]) (match-define (tick y major? _) t) - (list major? (plot->dc (vector x-min y)) (if major? radius 1/2radius) 0)) + (list major? (plot->dc* (vector x-min y)) (if major? radius 1/2radius) 0)) (for/list ([t (in-list (if (plot-x-far-axis?) x-far-ticks empty))]) (match-define (tick x major? _) t) - (list major? (plot->dc (vector x y-max)) (if major? radius 1/2radius) (* 1/2 pi))) + (list major? (plot->dc* (vector x y-max)) (if major? radius 1/2radius) (* 1/2 pi))) (for/list ([t (in-list (if (plot-y-far-axis?) y-far-ticks empty))]) (match-define (tick y major? _) t) - (list major? (plot->dc (vector x-max y)) (if major? radius 1/2radius) 0)))] + (list major? (plot->dc* (vector x-max y)) (if major? radius 1/2radius) 0)))] [else empty])) ;; =============================================================================================== @@ -290,9 +292,9 @@ (define (new-margins left right top bottom label-params tick-params) (match-define (list (vector label-xs label-ys) ...) - (append* (map (λ (params) (send/apply this get-text-corners params)) label-params))) + (append* (map (λ (params) (send/apply pd get-text-corners params)) label-params))) (match-define (list (vector tick-xs tick-ys) ...) - (append* (map (λ (params) (send/apply this get-tick-endpoints (rest params))) tick-params))) + (append* (map (λ (params) (send/apply pd get-tick-endpoints (rest params))) tick-params))) (define xs (append label-xs tick-xs)) (define ys (append label-ys tick-ys)) @@ -322,95 +324,89 @@ (define (draw-labels) (for ([params (in-list (get-label-params))]) - (send/apply this draw-text params))) + (send/apply pd draw-text params))) (define (draw-ticks) (for ([params (in-list (get-tick-params))]) (match-define (list major? v r angle) params) - (if major? (set-major-pen) (set-minor-pen)) - (send this draw-tick v r angle))) + (if major? (put-major-pen) (put-minor-pen)) + (send pd draw-tick v r angle))) (define (draw-title) (when (and (plot-decorations?) (plot-title)) - (draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top))) + (send pd draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top))) (define (draw-borders) (when (plot-decorations?) - (set-minor-pen) - (when (plot-x-axis?) (draw-line (vector area-x-min area-y-max) - (vector area-x-max area-y-max))) - (when (plot-x-far-axis?) (draw-line (vector area-x-min area-y-min) - (vector area-x-max area-y-min))) - (when (plot-y-axis?) (draw-line (vector area-x-min area-y-min) - (vector area-x-min area-y-max))) - (when (plot-y-far-axis?) (draw-line (vector area-x-max area-y-min) - (vector area-x-max area-y-max))))) + (put-minor-pen) + (when (plot-x-axis?) (send pd draw-line + (vector area-x-min area-y-max) + (vector area-x-max area-y-max))) + (when (plot-x-far-axis?) (send pd draw-line + (vector area-x-min area-y-min) + (vector area-x-max area-y-min))) + (when (plot-y-axis?) (send pd draw-line + (vector area-x-min area-y-min) + (vector area-x-min area-y-max))) + (when (plot-y-far-axis?) (send pd draw-line + (vector area-x-max area-y-min) + (vector area-x-max area-y-max))))) ;; =============================================================================================== - ;; Drawing + ;; Public drawing control (used by plot/dc) (define/public (start-plot) - (reset-drawing-params) - (clear) + (send pd reset-drawing-params) + (send pd clear) (draw-borders) (draw-ticks)) (define/public (start-renderer rx-min rx-max ry-min ry-max) - (reset-drawing-params) - (set-clipping-rect (vector (+ 1/2 (- area-x-min (plot-line-width))) - (+ 1/2 (- area-y-min (plot-line-width)))) - (vector (+ area-x-max (plot-line-width)) - (+ area-y-max (plot-line-width)))) + (send pd reset-drawing-params) + (send pd set-clipping-rect (vector (+ 1/2 (- area-x-min (plot-line-width))) + (+ 1/2 (- area-y-min (plot-line-width)))) + (vector (+ area-x-max (plot-line-width)) + (+ area-y-max (plot-line-width)))) (clip-to-bounds rx-min rx-max ry-min ry-max)) - (define/public (end-plot) - (clear-clipping-rect) + (define/public (end-renderers) + (send pd clear-clipping-rect) (clip-to-none) - (reset-drawing-params) + (send pd reset-drawing-params) (draw-title) (draw-labels)) (define/public (draw-legend legend-entries) (define gap-size (+ (pen-gap) (* 1/2 (plot-tick-size)))) - (draw-legend-box legend-entries - (+ area-x-min gap-size) (- area-x-max gap-size) - (+ area-y-min gap-size) (- area-y-max gap-size))) + (send pd draw-legend + legend-entries + (+ area-x-min gap-size) (- area-x-max gap-size) + (+ area-y-min gap-size) (- area-y-max gap-size))) - (define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7)) + (define/public (end-plot) + (send pd restore-drawing-params)) - (define (subdivide-line v1 v2 [depth 10]) - (let/ec return - (when (zero? depth) (return (list v1 v2))) - - (define dc-v1 (plot->dc v1)) - (define dc-v2 (plot->dc v2)) - (define dc-dv (v- dc-v2 dc-v1)) - (when ((vmag dc-dv) . <= . 3) - (return (list v1 v2))) - - (define dv (v- v2 v1)) - (define-values (max-area vc) - (for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)]) - (define test-vc (v+ (v* dv frac) v1)) - (define test-area (abs (vcross2 dc-dv (v- (plot->dc test-vc) dc-v1)))) - (cond [(test-area . > . max-area) (values test-area test-vc)] - [else (values max-area vc)]))) - (when (max-area . <= . 3) (return (list v1 v2))) - - ;(plot2d-subdivisions (+ (plot2d-subdivisions) 1)) - (append (subdivide-line v1 vc (- depth 1)) - (rest (subdivide-line vc v2 (- depth 1)))))) + ;; =============================================================================================== + ;; Public drawing interface (used by renderers) - (define (subdivide-lines vs) - (append - (append* - (for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))]) - (define line-vs (subdivide-line v1 v2)) - (take line-vs (sub1 (length line-vs))))) - (list (last vs)))) + (define/public (get-plot-device) pd) - (define (subdivide-polygon vs) - (subdivide-lines (append vs (list (first vs))))) + (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-major-pen [style 'solid]) (send pd set-major-pen style)) + (define/public (put-minor-pen [style 'solid]) (send pd set-minor-pen style)) + + (define/public (put-brush color style) (send pd set-brush color style)) + + (define/public (put-background color) (send pd set-background color)) + + (define/public (put-font-size size) (send pd set-font-size size)) + (define/public (put-font-family family) (send pd set-font-family family)) + (define/public (put-font size family) (send pd set-font size family)) + (define/public (put-text-foreground color) (send pd set-text-foreground color)) + + ;; Shapes (define/public (put-lines vs) (for ([vs (vregular-sublists vs)]) @@ -419,8 +415,8 @@ clip-y-min clip-y-max)) (in-value vs))]) (when (not (empty? vs)) - (let ([vs (if identity-transforms? vs (subdivide-lines vs))]) - (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 (vregular? v1) (vregular? v2)) @@ -430,9 +426,9 @@ (values v1 v2))]) (when (and v1 v2) (if identity-transforms? - (draw-line (plot->dc v1) (plot->dc v2)) - (draw-lines (map (λ (v) (plot->dc v)) - (subdivide-line 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 vregular? vs) @@ -442,9 +438,9 @@ vs)]) (when (not (empty? vs)) (if identity-transforms? - (draw-polygon (map (λ (v) (plot->dc v)) vs)) - (draw-polygon (map (λ (v) (plot->dc v)) - (subdivide-polygon 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-rectangle v1 v2) (when (and (vregular? v1) (vregular? v2)) @@ -453,29 +449,24 @@ clip-y-min clip-y-max) (values v1 v2))]) (when (and v1 v2) - (draw-rectangle (plot->dc v1) (plot->dc v2)))))) - - (define (in-bounds? v) - (or (not clipping?) - (point-in-bounds? v clip-x-min clip-x-max - clip-y-min clip-y-max))) + (send pd draw-rectangle (plot->dc* v1) (plot->dc* v2)))))) (define/public (put-text str v [anchor 'top-left] [angle 0] #:outline? [outline? #f]) (when (and (vregular? v) (in-bounds? v)) - (draw-text str (plot->dc v) anchor angle #:outline? outline?))) + (send pd draw-text str (plot->dc* v) anchor angle #:outline? outline?))) (define/public (put-glyphs vs symbol size) - (draw-glyphs (map (λ (v) (plot->dc v)) - (filter (λ (v) (and (vregular? v) (in-bounds? v))) - vs)) - symbol size)) + (send pd draw-glyphs (map (λ (v) (plot->dc* v)) + (filter (λ (v) (and (vregular? v) (in-bounds? v))) + vs)) + symbol size)) (define/public (put-arrow v1 v2) (when (and (vregular? v1) (vregular? v2) (in-bounds? v1)) - (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 (vregular? v) (in-bounds? v)) - (draw-tick (plot->dc v) r angle))) + (send pd draw-tick (plot->dc* v) r angle))) )) diff --git a/collects/plot/plot2d/contour.rkt b/collects/plot/plot2d/contour.rkt index 4ebffccba4..df666126a5 100644 --- a/collects/plot/plot2d/contour.rkt +++ b/collects/plot/plot2d/contour.rkt @@ -19,8 +19,8 @@ (g x-min x-max samples y-min y-max samples)) (when (<= z-min z z-max) - (send area set-alpha alpha) - (send area set-pen color width style) + (send area put-alpha alpha) + (send area put-pen color width style) (for ([ya (in-list ys)] [yb (in-list (rest ys))] [zs0 (in-vector zss)] @@ -74,8 +74,8 @@ [width (in-cycle ws)] [style (in-cycle ss)] [alpha (in-cycle as)]) - (send area set-alpha alpha) - (send area set-pen color width style) + (send area put-alpha alpha) + (send area put-pen color width style) (for ([ya (in-list ys)] [yb (in-list (rest ys))] [zs0 (in-vector zss)] @@ -155,20 +155,20 @@ (send area put-polygon poly))) (cond [(= alpha 1) - (send area set-pen color 1 poly-line-style) - (send area set-brush color fill-style) - (send area set-alpha 1) + (send area put-pen color 1 poly-line-style) + (send area put-brush color fill-style) + (send area put-alpha 1) (draw-polys)] [else ;; draw the outlines with reduced alpha first - (send area set-pen color 1 poly-line-style) - (send area set-brush color 'transparent) - (send area set-alpha (alpha-expt alpha 1/8)) + (send area put-pen color 1 poly-line-style) + (send area put-brush color 'transparent) + (send area put-alpha (alpha-expt alpha 1/8)) (draw-polys) ;; now draw the centers - (send area set-pen color 1 'transparent) - (send area set-brush color fill-style) - (send area set-alpha alpha) + (send area put-pen color 1 'transparent) + (send area put-brush color fill-style) + (send area put-alpha alpha) (draw-polys)])) ((contours-render-proc g levels samples contour-colors contour-widths contour-styles alphas #f) diff --git a/collects/plot/plot2d/decoration.rkt b/collects/plot/plot2d/decoration.rkt index e85cb4066b..6113cdaeff 100644 --- a/collects/plot/plot2d/decoration.rkt +++ b/collects/plot/plot2d/decoration.rkt @@ -22,21 +22,22 @@ (define x-ticks (if far? (send area get-x-far-ticks) (send area get-x-ticks))) (define radius (if ticks? (* 1/2 (plot-tick-size)) 0)) - (send area set-alpha alpha) - (send area set-major-pen) + (send area put-alpha alpha) + (send area put-major-pen) (send area put-line (vector x-min y) (vector x-max y)) (when ticks? (for ([t (in-list x-ticks)]) (match-define (tick x major? _) t) - (if major? (send area set-major-pen) (send area set-minor-pen)) + (if major? (send area put-major-pen) (send area put-minor-pen)) (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)))) (for ([t (in-list x-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (send area draw-text label + (send pd draw-text label ((if far? v- v+) (send area plot->dc (vector x y)) offset) (if far? 'bottom 'top) 0))) @@ -55,21 +56,22 @@ (define y-ticks (if far? (send area get-y-far-ticks) (send area get-y-ticks))) (define radius (if ticks? (* 1/2 (plot-tick-size)) 0)) - (send area set-alpha alpha) - (send area set-major-pen) + (send area put-alpha alpha) + (send area put-major-pen) (send area put-line (vector x y-min) (vector x y-max)) (when ticks? (for ([t (in-list y-ticks)]) (match-define (tick y major? _) t) - (if major? (send area set-major-pen) (send area set-minor-pen)) + (if major? (send area put-major-pen) (send area put-minor-pen)) (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)) (for ([t (in-list y-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (send area draw-text label + (send pd draw-text label ((if far? v+ v-) (send area plot->dc (vector x y)) offset) (if far? 'left 'right) 0))) @@ -125,7 +127,7 @@ ;; Draw the tick lines (for ([t (in-list ts)]) (match-define (tick r major? label) t) - (if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash)) + (if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash)) (define pts (for/list ([θ (in-list (linear-seq 0 (* 2 pi) 500))]) (vector (* r (cos θ)) (* r (sin θ))))) (send area put-lines pts)) @@ -147,14 +149,14 @@ (define-values (x-min x-max y-min y-max) (send area get-bounds)) (define-values (θs r-mins r-maxs) (build-polar-axes num x-min x-max y-min y-max)) - (send area set-major-pen) + (send area put-major-pen) (for ([θ (in-list θs)] [r-min (in-list r-mins)] [r-max (in-list r-maxs)]) (send area put-line (vector (* r-min (cos θ)) (* r-min (sin θ))) (vector (* r-max (cos θ)) (* r-max (sin θ)))))) (define ((polar-axes-render-proc num ticks? labels? alpha) area) - (send area set-alpha alpha) + (send area put-alpha alpha) (when (num . > . 0) (draw-polar-axis-lines num area)) (when ticks? (draw-polar-axis-ticks (if (num . > . 0) num 12) labels? area)) empty) @@ -173,10 +175,10 @@ (define y-max (send area get-y-max)) (define x-ticks (send area get-x-ticks)) - (send area set-alpha 1/2) + (send area put-alpha 1/2) (for ([t (in-list x-ticks)]) (match-define (tick x major? _) t) - (if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash)) + (if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash)) (send area put-line (vector x y-min) (vector x y-max))) empty) @@ -186,10 +188,10 @@ (define x-max (send area get-x-max)) (define y-ticks (send area get-y-ticks)) - (send area set-alpha 1/2) + (send area put-alpha 1/2) (for ([t (in-list y-ticks)]) (match-define (tick y major? _) t) - (if major? (send area set-minor-pen) (send area set-minor-pen 'long-dash)) + (if major? (send area put-minor-pen) (send area put-minor-pen 'long-dash)) (send area put-line (vector x-min y) (vector x-max y))) empty) @@ -222,13 +224,13 @@ (define ((label-render-proc label v color size family anchor angle point-size alpha) area) (let ([label (if label label (format-coordinate v area))]) - (send area set-alpha alpha) + (send area put-alpha alpha) ; label - (send area set-text-foreground color) - (send area set-font size family) + (send area put-text-foreground color) + (send area put-font size family) (send area put-text (string-append " " label " ") v anchor angle #:outline? #t) ; point - (send area set-pen color 1 'solid) + (send area put-pen color 1 'solid) (send area put-glyphs (list v) 'fullcircle point-size)) empty) diff --git a/collects/plot/plot2d/interval.rkt b/collects/plot/plot2d/interval.rkt index 3a613f0dfd..6d9d4f0a64 100644 --- a/collects/plot/plot2d/interval.rkt +++ b/collects/plot/plot2d/interval.rkt @@ -16,15 +16,15 @@ line2-color line2-width line2-style alpha label) area) - (send area set-alpha alpha) - (send area set-pen 0 0 'transparent) - (send area set-brush color style) + (send area put-alpha alpha) + (send area put-pen 0 0 'transparent) + (send area put-brush color style) (send area put-polygon (append v1s (reverse v2s))) - (send area set-pen line1-color line1-width line1-style) + (send area put-pen line1-color line1-width line1-style) (send area put-lines v1s) - (send area set-pen line2-color line2-width line2-style) + (send area put-pen line2-color line2-width line2-style) (send area put-lines v2s) (cond [label (interval-legend-entry label color style 0 0 'transparent @@ -127,8 +127,8 @@ area) (define x-min (send area get-x-min)) (define x-max (send area get-x-max)) - (match-define (list x1s y1s) (f1 x-min x-max samples)) - (match-define (list x2s y2s) (f2 x-min x-max samples)) + (match-define (sample x1s y1s y1-min y1-max) (f1 x-min x-max samples)) + (match-define (sample x2s y2s y2-min y2-max) (f2 x-min x-max samples)) (define v1s (map vector x1s y1s)) (define v2s (map vector x2s y2s)) @@ -174,8 +174,8 @@ area) (define y-min (send area get-y-min)) (define y-max (send area get-y-max)) - (match-define (list y1s x1s) (f1 y-min y-max samples)) - (match-define (list y2s x2s) (f2 y-min y-max samples)) + (match-define (sample y1s x1s x1-min x1-max) (f1 y-min y-max samples)) + (match-define (sample y2s x2s x2-min x2-max) (f2 y-min y-max samples)) (define v1s (map vector x1s y1s)) (define v2s (map vector x2s y2s)) diff --git a/collects/plot/plot2d/line.rkt b/collects/plot/plot2d/line.rkt index 02588914c5..0e4b02ad0c 100644 --- a/collects/plot/plot2d/line.rkt +++ b/collects/plot/plot2d/line.rkt @@ -12,8 +12,8 @@ ;; Lines, parametric, polar (define ((lines-render-proc vs color width style alpha label) area) - (send area set-alpha alpha) - (send area set-pen color width style) + (send area put-alpha alpha) + (send area put-pen color width style) (send area put-lines vs) (cond [label (line-legend-entry label color width style)] @@ -80,8 +80,8 @@ (define x-max (send area get-x-max)) (match-define (sample xs ys y-min y-max) (f x-min x-max samples)) - (send area set-alpha alpha) - (send area set-pen color width style) + (send area put-alpha alpha) + (send area put-pen color width style) (send area put-lines (map vector xs ys)) (cond [label (line-legend-entry label color width style)] @@ -109,10 +109,10 @@ (define ((inverse-render-proc f samples color width style alpha label) area) (define y-min (send area get-y-min)) (define y-max (send area get-y-max)) - (match-define (list ys xs x-min x-max) (f y-min y-max samples)) + (match-define (sample ys xs x-min x-max) (f y-min y-max samples)) - (send area set-alpha alpha) - (send area set-pen color width style) + (send area put-alpha alpha) + (send area put-pen color width style) (send area put-lines (map vector xs ys)) (cond [label (line-legend-entry label color width style)] diff --git a/collects/plot/plot2d/plot.rkt b/collects/plot/plot2d/plot.rkt index c5728273a1..16f1db870a 100644 --- a/collects/plot/plot2d/plot.rkt +++ b/collects/plot/plot2d/plot.rkt @@ -82,12 +82,12 @@ (send area start-renderer rx-min rx-max ry-min ry-max) (if render-proc (render-proc area) empty)))) - (send area end-plot) + (send area end-renderers) (when (not (empty? legend-entries)) (send area draw-legend legend-entries)) - (send area restore-drawing-params))) + (send area end-plot))) ;; =================================================================================================== ;; Plot to various other backends diff --git a/collects/plot/plot2d/point.rkt b/collects/plot/plot2d/point.rkt index 46c28dfac9..243d0247cd 100644 --- a/collects/plot/plot2d/point.rkt +++ b/collects/plot/plot2d/point.rkt @@ -13,8 +13,8 @@ ;; Points (scatter plots) (define ((points-render-fun vs sym color size line-width alpha label) area) - (send area set-alpha alpha) - (send area set-pen color line-width 'solid) + (send area put-alpha alpha) + (send area put-pen color line-width 'solid) (send area put-glyphs vs sym size) (if label (point-legend-entry label sym color size line-width) empty)) @@ -71,8 +71,8 @@ (/ box-y-size dy-max))) (map (λ (mag) (* scale mag)) mags)])) - (send area set-alpha alpha) - (send area set-pen color line-width line-style) + (send area put-alpha alpha) + (send area put-pen color line-width line-style) (for ([x (in-list xs)] [y (in-list ys)] [angle (in-list angles)] @@ -108,24 +108,17 @@ (define ((error-bars-render-fun xs ys hs color line-width line-style width alpha) area) (define-values (x-min x-max y-min y-max) (send area get-clip-bounds)) - (define half (* 1/2 width)) + (define radius (* 1/2 width)) - (send area set-alpha alpha) - (send area set-pen color line-width line-style) + (send area put-alpha alpha) + (send area put-pen color line-width line-style) (for ([x (in-list xs)] [y (in-list ys)] [h (in-list hs)]) (when (point-in-bounds? (vector x y) x-min x-max y-min y-max) (define v1 (vector x (- y h))) (define v2 (vector x (+ y h))) (send area put-line v1 v2) - - (match-define (vector dc-x1 dc-y1) (send area plot->dc v1)) - (match-define (vector dc-x2 dc-y2) (send area plot->dc v2)) - (send area draw-line - (vector (- dc-x1 half) dc-y1) - (vector (+ dc-x1 half) dc-y1)) - (send area draw-line - (vector (- dc-x2 half) dc-y2) - (vector (+ dc-x2 half) dc-y2)))) + (send area put-tick v1 radius 0) + (send area put-tick v2 radius 0))) empty) diff --git a/collects/plot/plot2d/rectangle.rkt b/collects/plot/plot2d/rectangle.rkt index 2b0da7fbc7..e914879f90 100644 --- a/collects/plot/plot2d/rectangle.rkt +++ b/collects/plot/plot2d/rectangle.rkt @@ -14,9 +14,9 @@ (define ((rectangles-render-proc rects color style line-color line-width line-style alpha label) area) - (send area set-pen line-color line-width line-style) - (send area set-brush color style) - (send area set-alpha alpha) + (send area put-pen line-color line-width line-style) + (send area put-brush color style) + (send area put-alpha alpha) (for ([rect (in-list rects)]) (match-define (vector (ivl x1 x2) (ivl y1 y2)) rect) (send area put-rectangle (vector x1 y1) (vector x2 y2))) diff --git a/collects/plot/plot3d/area.rkt b/collects/plot/plot3d/area.rkt index c2b9514dcf..d1cd987593 100644 --- a/collects/plot/plot3d/area.rkt +++ b/collects/plot/plot3d/area.rkt @@ -2,7 +2,7 @@ (require racket/class racket/match racket/list racket/math racket/contract "../common/math.rkt" - "../common/area.rkt" + "../common/plot-device.rkt" "../common/ticks.rkt" "../common/draw.rkt" "../common/contract.rkt" @@ -18,23 +18,16 @@ (define plot3d-subdivisions (make-parameter 0)) (define 3d-plot-area% - (class plot-area% + (class object% (init-field rx-ticks rx-far-ticks ry-ticks ry-far-ticks rz-ticks rz-far-ticks x-min x-max y-min y-max z-min z-max) (init dc dc-x-min dc-y-min dc-x-size dc-y-size) - (inherit - set-alpha set-pen set-major-pen set-minor-pen set-brush set-background set-text-foreground - set-font reset-drawing-params - get-text-width get-text-extent get-char-height get-char-baseline - set-clipping-rect clear-clipping-rect - clear draw-polygon draw-rectangle draw-line draw-lines draw-text draw-glyphs draw-arrow-glyph - draw-tick draw-legend-box) + (super-new) - (super-make-object dc dc-x-min dc-y-min dc-x-size dc-y-size) + (define pd (make-object plot-device% dc dc-x-min dc-y-min dc-x-size dc-y-size)) + (send pd reset-drawing-params) - (reset-drawing-params) - - (define char-height (get-char-height)) + (define char-height (send pd get-char-height)) (define clipping? #f) (define clip-x-min x-min) @@ -128,7 +121,8 @@ (define view->dc #f) (define (plot->dc/no-axis-trans v) (view->dc (m3-apply transform-matrix (center v)))) - (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 dc-x-max (+ dc-x-min dc-x-size)) (define dc-y-max (+ dc-y-min dc-y-size)) @@ -163,7 +157,7 @@ (vector (+ area-x-mid x) (- area-y-mid z))))) ;; Initial view->dc - (define init-top-margin (if (and (plot-decorations?) (plot-title)) (* 3/2 (get-char-height)) 0)) + (define init-top-margin (if (and (plot-decorations?) (plot-title)) (* 3/2 char-height) 0)) (set! view->dc (make-view->dc 0 0 init-top-margin 0)) ;; =============================================================================================== @@ -183,7 +177,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-ticks-near? y) t1 t2) (vnear? (vector (pre-tick-value t1) y z-min) @@ -236,7 +230,7 @@ (define (max-tick-label-width ts) (apply max 0 (for/list ([t (in-list ts)] #:when (pre-tick-major? t)) - (get-text-width (tick-label t))))) + (send pd get-text-width (tick-label t))))) (define (max-x-tick-label-diag y-axis-angle) (if (plot-x-axis?) @@ -296,7 +290,7 @@ 'top (- (if y-axis-x-min? pi 0) y-axis-angle))) (define (get-z-label-params) - (list #t (plot-z-label) (v+ (plot->dc (vector z-axis-x z-axis-y z-max)) + (list #t (plot-z-label) (v+ (plot->dc* (vector z-axis-x z-axis-y z-max)) (vector 0 (* -1/2 char-height))) 'bottom-left 0)) @@ -321,7 +315,7 @@ 'bottom (- (if y-axis-x-min? pi 0) y-axis-angle))) (define (get-z-far-label-params) - (list #t (plot-z-far-label) (v+ (plot->dc (vector z-far-axis-x z-far-axis-y z-max)) + (list #t (plot-z-far-label) (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z-max)) (vector 0 (* -1/2 char-height))) 'bottom-right 0)) @@ -359,7 +353,7 @@ (if x-axis-y-min? (- dist) dist))) (for/list ([t (in-list x-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (list #f label (v+ (plot->dc (vector x x-axis-y z-min)) offset) + (list #f label (v+ (plot->dc* (vector x x-axis-y z-min)) offset) x-tick-label-anchor 0))) (define (get-y-tick-label-params) @@ -369,15 +363,15 @@ (if y-axis-x-min? (- dist) dist))) (for/list ([t (in-list y-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (list #f label (v+ (plot->dc (vector y-axis-x y z-min)) offset) + (list #f label (v+ (plot->dc* (vector y-axis-x y z-min)) offset) y-tick-label-anchor 0))) (define (get-z-tick-label-params) (define dist (+ (pen-gap) (* 1/2 (plot-tick-size)))) - (define offset (vector (- dist) (* 2 (get-char-baseline)))) + (define offset (vector (- dist) (* 2 (send pd get-char-baseline)))) (for/list ([t (in-list z-ticks)] #:when (pre-tick-major? t)) (match-define (tick z _ label) t) - (list #t label (v+ (plot->dc (vector z-axis-x z-axis-y z)) offset) 'bottom-right 0))) + (list #t label (v+ (plot->dc* (vector z-axis-x z-axis-y z)) offset) 'bottom-right 0))) (define (get-x-far-tick-label-params) (define y-axis-angle (plot-dir->dc-angle (vector 0 1 0))) @@ -386,7 +380,7 @@ (if x-axis-y-min? dist (- dist)))) (for/list ([t (in-list x-far-ticks)] #:when (pre-tick-major? t)) (match-define (tick x _ label) t) - (list #f label (v+ (plot->dc (vector x x-far-axis-y z-min)) offset) + (list #f label (v+ (plot->dc* (vector x x-far-axis-y z-min)) offset) x-far-tick-label-anchor 0))) (define (get-y-far-tick-label-params) @@ -396,15 +390,15 @@ (if y-axis-x-min? dist (- dist)))) (for/list ([t (in-list y-far-ticks)] #:when (pre-tick-major? t)) (match-define (tick y _ label) t) - (list #f label (v+ (plot->dc (vector y-far-axis-x y z-min)) offset) + (list #f label (v+ (plot->dc* (vector y-far-axis-x y z-min)) offset) y-far-tick-label-anchor 0))) (define (get-z-far-tick-label-params) (define dist (+ (pen-gap) (* 1/2 (plot-tick-size)))) - (define offset (vector dist (* 2 (get-char-baseline)))) + (define offset (vector dist (* 2 (send pd get-char-baseline)))) (for/list ([t (in-list z-far-ticks)] #:when (pre-tick-major? t)) (match-define (tick z _ label) t) - (list #t label (v+ (plot->dc (vector z-far-axis-x z-far-axis-y z)) offset) + (list #t label (v+ (plot->dc* (vector z-far-axis-x z-far-axis-y z)) offset) 'bottom-left 0))) ;; =============================================================================================== @@ -415,7 +409,7 @@ (define angle (plot-dir->dc-angle (vector 0 1 0))) (for/list ([t (in-list x-ticks)]) (match-define (tick x major? _) t) - (list major? (plot->dc (vector x x-axis-y z-min)) + (list major? (plot->dc* (vector x x-axis-y z-min)) (if major? radius (* 1/2 radius)) angle))) (define (get-y-tick-params) @@ -423,14 +417,14 @@ (define angle (plot-dir->dc-angle (vector 1 0 0))) (for/list ([t (in-list y-ticks)]) (match-define (tick y major? _) t) - (list major? (plot->dc (vector y-axis-x y z-min)) + (list major? (plot->dc* (vector y-axis-x y z-min)) (if major? radius (* 1/2 radius)) angle))) (define (get-z-tick-params) (define radius (* 1/2 (plot-tick-size))) (for/list ([t (in-list z-ticks)]) (match-define (tick z major? _) t) - (list major? (plot->dc (vector z-axis-x z-axis-y z)) + (list major? (plot->dc* (vector z-axis-x z-axis-y z)) (if major? radius (* 1/2 radius)) 0))) (define (get-x-far-tick-params) @@ -438,7 +432,7 @@ (define angle (plot-dir->dc-angle (vector 0 1 0))) (for/list ([t (in-list x-ticks)]) (match-define (tick x major? _) t) - (list major? (plot->dc (vector x x-far-axis-y z-min)) + (list major? (plot->dc* (vector x x-far-axis-y z-min)) (if major? radius (* 1/2 radius)) angle))) (define (get-y-far-tick-params) @@ -446,14 +440,14 @@ (define angle (plot-dir->dc-angle (vector 1 0 0))) (for/list ([t (in-list y-ticks)]) (match-define (tick y major? _) t) - (list major? (plot->dc (vector y-far-axis-x y z-min)) + (list major? (plot->dc* (vector y-far-axis-x y z-min)) (if major? radius (* 1/2 radius)) angle))) (define (get-z-far-tick-params) (define radius (* 1/2 (plot-tick-size))) (for/list ([t (in-list z-ticks)]) (match-define (tick z major? _) t) - (list major? (plot->dc (vector z-far-axis-x z-far-axis-y z)) + (list major? (plot->dc* (vector z-far-axis-x z-far-axis-y z)) (if major? radius (* 1/2 radius)) 0))) ;; =============================================================================================== @@ -519,9 +513,9 @@ (define (new-margins left right top bottom label-params tick-params) (match-define (list (vector label-xs label-ys) ...) - (append* (map (λ (params) (send/apply this get-text-corners (rest params))) label-params))) + (append* (map (λ (params) (send/apply pd get-text-corners (rest params))) label-params))) (match-define (list (vector tick-xs tick-ys) ...) - (append* (map (λ (params) (send/apply this get-tick-endpoints (rest params))) tick-params))) + (append* (map (λ (params) (send/apply pd get-tick-endpoints (rest params))) tick-params))) (define xs (append label-xs tick-xs)) (define ys (append label-ys tick-ys)) @@ -546,104 +540,93 @@ (values new-left new-right new-top new-bottom))) ;; =============================================================================================== - + ;; Plot decoration + (define (draw-ticks tick-params) (for ([params (in-list tick-params)]) (match-define (list major? v r angle) params) - (if major? (set-major-pen) (set-minor-pen)) - (send this draw-tick v r angle))) + (if major? (send pd set-major-pen) (send pd set-minor-pen)) + (send pd draw-tick v r angle))) (define (draw-labels label-params) (for ([params (in-list label-params)]) - (send/apply this draw-text (rest params) #:outline? (first params)))) + (send/apply pd draw-text (rest params) #:outline? (first params)))) (define (draw-far-borders) (when (plot-decorations?) - (set-minor-pen) + (send pd set-minor-pen) (when (plot-x-axis?) - (draw-line (plot->dc/no-axis-trans (vector x-min x-axis-y z-min)) - (plot->dc/no-axis-trans (vector x-max x-axis-y z-min)))) + (send pd draw-line + (plot->dc/no-axis-trans (vector x-min x-axis-y z-min)) + (plot->dc/no-axis-trans (vector x-max x-axis-y z-min)))) (when (plot-x-far-axis?) - (draw-line (plot->dc/no-axis-trans (vector x-min x-far-axis-y z-min)) - (plot->dc/no-axis-trans (vector x-max x-far-axis-y z-min)))) + (send pd draw-line + (plot->dc/no-axis-trans (vector x-min x-far-axis-y z-min)) + (plot->dc/no-axis-trans (vector x-max x-far-axis-y z-min)))) (when (plot-y-axis?) - (draw-line (plot->dc/no-axis-trans (vector y-axis-x y-min z-min)) - (plot->dc/no-axis-trans (vector y-axis-x y-max z-min)))) + (send pd draw-line + (plot->dc/no-axis-trans (vector y-axis-x y-min z-min)) + (plot->dc/no-axis-trans (vector y-axis-x y-max z-min)))) (when (plot-y-far-axis?) - (draw-line (plot->dc/no-axis-trans (vector y-far-axis-x y-min z-min)) - (plot->dc/no-axis-trans (vector y-far-axis-x y-max z-min)))))) + (send pd draw-line + (plot->dc/no-axis-trans (vector y-far-axis-x y-min z-min)) + (plot->dc/no-axis-trans (vector y-far-axis-x y-max z-min)))))) (define (draw-near-borders) (when (plot-decorations?) - (set-minor-pen) + (send pd set-minor-pen) (when (plot-z-axis?) - (draw-line (plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-min)) - (plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-max)))) + (send pd draw-line + (plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-min)) + (plot->dc/no-axis-trans (vector z-axis-x z-axis-y z-max)))) (when (plot-z-far-axis?) - (draw-line (plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-min)) - (plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-max)))))) + (send pd draw-line + (plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-min)) + (plot->dc/no-axis-trans (vector z-far-axis-x z-far-axis-y z-max)))))) (define (draw-title) (when (and (plot-decorations?) (plot-title)) - (draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top))) + (send pd draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top))) - (define/public (start-plot) - (reset-drawing-params) - (clear) - (set! render-list empty) - (draw-labels (get-far-label-params)) - (draw-ticks (get-far-tick-params)) - (draw-far-borders)) + ;; =============================================================================================== + ;; Delayed drawing - (define/public (start-renderer rx-min rx-max ry-min ry-max rz-min rz-max) - (reset-drawing-params) - (clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max)) - - (define/public (end-plot) - (draw-render-list) - (clip-to-none) - (reset-drawing-params) - (draw-title) - (draw-near-borders) - (draw-ticks (get-near-tick-params)) - (draw-labels (get-near-label-params))) - - (define (put-major-pen) (put-pen (plot-foreground) (plot-line-width) 'solid)) - (define (put-minor-pen) (put-pen (plot-foreground) (* 1/2 (plot-line-width)) 'solid)) - - (define (draw-angles*) - (define angle-str (format " angle = ~a " (number->string (round angle)))) - (define alt-str (format " altitude = ~a " (number->string (round altitude)))) - (define-values (angle-width angle-height baseline _angle2) (get-text-extent angle-str)) - (define-values (alt-width alt-height _alt1 _alt2) (get-text-extent alt-str)) - - (define box-x-size (max angle-width alt-width)) - (define box-y-size (+ angle-height alt-height (* 3 baseline))) - (define box-x-min (+ dc-x-min (* 1/2 (- dc-x-size box-x-size)))) - (define box-y-min (+ dc-y-min (* 1/2 (- dc-y-size box-y-size)))) - (define box-x-max (+ box-x-min box-x-size)) - (define box-y-max (+ box-y-min box-y-size)) - - (set-alpha 1/2) - (set-minor-pen) - (set-brush (plot-background) 'solid) - (draw-rectangle (vector box-x-min box-y-min) (vector box-x-max box-y-max)) - - (set-alpha 1) - (draw-text angle-str (vector box-x-min (+ box-y-min baseline)) - 'top-left #:outline? #t) - (draw-text alt-str (vector box-x-min (+ box-y-min baseline char-height)) - 'top-left #:outline? #t)) - - (define/public (draw-angles) (draw-angles*)) - - (define (draw-legend* legend-entries) - (define gap (plot-line-width)) - (draw-legend-box legend-entries - (+ dc-x-min gap) (- dc-x-max gap) - (+ area-y-min gap) (- dc-y-max gap))) - - (define/public (draw-legend legend-entries) (draw-legend* legend-entries)) + (define render-list empty) + (define (add-shape! shape) (set! render-list (cons shape render-list))) + + (define (draw-shapes lst) + (for ([s (in-list (depth-sort lst))]) + (send pd set-alpha (shape-alpha s)) + (match s + ; shapes + [(shapes alpha center ss) (draw-shapes ss)] + ; polygon + [(polygon alpha center vs normal pen-color pen-width pen-style brush-color brush-style) + (define-values (diff spec) (get-light-values center normal)) + (let ([pen-color (map (λ (v) (+ (* v diff) spec)) pen-color)] + [brush-color (map (λ (v) (+ (* v diff) spec)) brush-color)]) + (send pd set-pen pen-color pen-width pen-style) + (send pd set-brush brush-color brush-style) + (send pd draw-polygon (map (λ (v) (view->dc v)) vs)))] + ; line + [(line alpha center v1 v2 pen-color pen-width pen-style) + (send pd set-pen pen-color pen-width pen-style) + (send pd draw-line (view->dc v1) (view->dc v2))] + ; text + [(text alpha center anchor angle 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 (rotate/rho center)) anchor angle)] + ; glyph + [(glyph alpha center 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-brush brush-color brush-style) + (send pd draw-glyphs (list (view->dc (rotate/rho center))) symbol size)] + ; tick glyph + [(tick-glyph alpha center radius angle pen-color pen-width pen-style) + (send pd set-pen pen-color pen-width pen-style) + (send pd draw-tick (view->dc (rotate/rho center)) radius angle)] + [_ (error 'draw-shapes "shape not implemented: ~e" s)]))) (define light (plot->view (vector x-mid y-mid (+ z-max (* 5 z-size))))) (define view-dir (vector 0 -50 0)) @@ -670,48 +653,76 @@ ; put it all together (values (+ ambient-light (* (- 1 ambient-light) diff)) spec))])) - (define (draw-shapes lst) - (for ([s (in-list (depth-sort lst))]) - (set-alpha (shape-alpha s)) - (match s - ; shapes - [(shapes alpha center ss) (draw-shapes ss)] - ; polygon - [(polygon alpha center vs normal pen-color pen-width pen-style brush-color brush-style) - (define-values (diff spec) (get-light-values center normal)) - (let ([pen-color (map (λ (v) (+ (* v diff) spec)) pen-color)] - [brush-color (map (λ (v) (+ (* v diff) spec)) brush-color)]) - (set-pen pen-color pen-width pen-style) - (set-brush brush-color brush-style) - (draw-polygon (map (λ (v) (view->dc v)) vs)))] - ; line - [(line alpha center v1 v2 pen-color pen-width pen-style) - (set-pen pen-color pen-width pen-style) - (draw-line (view->dc v1) (view->dc v2))] - ; text - [(text alpha center anchor angle str font-size font-family color) - (set-font font-size font-family) - (set-text-foreground color) - (draw-text str (view->dc (rotate/rho center)) anchor angle)] - ; glyph - [(glyph alpha center symbol size pen-color pen-width pen-style brush-color brush-style) - (set-pen pen-color pen-width pen-style) - (set-brush brush-color brush-style) - (draw-glyphs (list (view->dc (rotate/rho center))) symbol size)] - ; tick glyph - [(tick-glyph alpha center radius angle pen-color pen-width pen-style) - (set-pen pen-color pen-width pen-style) - (draw-tick (view->dc (rotate/rho center)) radius angle)] - [_ (error 'end-plot "shape not implemented: ~e" s)]))) + ;; =============================================================================================== + ;; Public drawing control (used by plot3d/dc) + + (define/public (start-plot) + (send pd reset-drawing-params) + (send pd clear) + (set! render-list empty) + (draw-labels (get-far-label-params)) + (draw-ticks (get-far-tick-params)) + (draw-far-borders)) + + (define/public (start-renderer rx-min rx-max ry-min ry-max rz-min rz-max) + (send pd reset-drawing-params) + (clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max)) + + (define/public (end-renderers) + (draw-shapes render-list) + (clip-to-none) + (send pd reset-drawing-params) + (draw-title) + (draw-near-borders) + (draw-ticks (get-near-tick-params)) + (draw-labels (get-near-label-params))) + + (define (draw-angles*) + (define angle-str (format " angle = ~a " (number->string (round angle)))) + (define alt-str (format " altitude = ~a " (number->string (round altitude)))) + (define-values (angle-width angle-height baseline _angle2) (send pd get-text-extent angle-str)) + (define-values (alt-width alt-height _alt1 _alt2) (send pd get-text-extent alt-str)) + + (define box-x-size (max angle-width alt-width)) + (define box-y-size (+ angle-height alt-height (* 3 baseline))) + (define box-x-min (+ dc-x-min (* 1/2 (- dc-x-size box-x-size)))) + (define box-y-min (+ dc-y-min (* 1/2 (- dc-y-size box-y-size)))) + (define box-x-max (+ box-x-min box-x-size)) + (define box-y-max (+ box-y-min box-y-size)) + + (send pd set-alpha 1/2) + (send pd set-minor-pen) + (send pd set-brush (plot-background) 'solid) + (send pd draw-rectangle (vector box-x-min box-y-min) (vector box-x-max box-y-max)) + + (send pd set-alpha 1) + (send pd draw-text + angle-str (vector box-x-min (+ box-y-min baseline)) + 'top-left #:outline? #t) + (send pd draw-text + alt-str (vector box-x-min (+ box-y-min baseline char-height)) + 'top-left #:outline? #t)) + + (define/public (draw-angles) (draw-angles*)) + + (define (draw-legend* legend-entries) + (define gap (plot-line-width)) + (send pd draw-legend + legend-entries + (+ dc-x-min gap) (- dc-x-max gap) + (+ area-y-min gap) (- dc-y-max gap))) + + (define/public (draw-legend legend-entries) (draw-legend* legend-entries)) + + (define/public (end-plot) + (send pd restore-drawing-params)) ;; =============================================================================================== - ;; Delayed drawing + ;; Public drawing interface (used by renderers) - (define render-list empty) - (define (add-shape! shape) (set! render-list (cons shape render-list))) - (define (draw-render-list) (draw-shapes render-list)) + (define/public (get-plot-device) pd) - ; drawing parameters + ;; Drawing parameters (define alpha 1) @@ -728,26 +739,25 @@ (define font-family 'roman) (define text-foreground '(0 0 0)) - ;; drawing parameter accessors - - ; alpha + ;; Drawing parameter accessors (define/public (put-alpha a) (set! alpha a)) (define (get-alpha) alpha) - ; pen - (define/public (put-pen color width style) (set! pen-color (->pen-color color)) (set! pen-width width) (set! pen-style (->pen-style style))) + (define/public (put-major-pen [style 'solid]) + (put-pen (plot-foreground) (plot-line-width) style)) + (define/public (put-minor-pen [style 'solid]) + (put-pen (plot-foreground) (* 1/2 (plot-line-width)) style)) + (define (get-pen-color) pen-color) (define (get-pen-width) pen-width) (define (get-pen-style) pen-style) - ; brush - (define/public (put-brush color style) (set! brush-color (->brush-color color)) (set! brush-style (->brush-style style))) @@ -755,14 +765,10 @@ (define (get-brush-color) brush-color) (define (get-brush-style) brush-style) - ; background color - (define/public (put-background color) (set! background-color (->brush-color color))) (define (get-background) background-color) - ; font - (define/public (put-font-size size) (set! font-size size)) (define/public (put-font-family family) (set! font-family family)) @@ -777,46 +783,7 @@ (define (get-font-family) font-family) (define (get-text-foreground) text-foreground) - ;; =============================================================================================== - ;; Subdividing nonlinearly transformed shapes - - (define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7)) - - (define (subdivide-line v1 v2 [depth 10]) - (let/ec return - (when (zero? depth) (return (list v1 v2))) - - (define dc-v1 (plot->dc v1)) - (define dc-v2 (plot->dc v2)) - (define dc-dv (v- dc-v2 dc-v1)) - (when ((vmag dc-dv) . <= . 3) - (return (list v1 v2))) - - (define dv (v- v2 v1)) - (define-values (max-area vc) - (for/fold ([max-area 0] [vc v1]) ([frac (in-list subdivide-fracs)]) - (define test-vc (v+ (v* dv frac) v1)) - (define test-area (abs (vcross2 dc-dv (v- (plot->dc test-vc) dc-v1)))) - (cond [(test-area . > . max-area) (values test-area test-vc)] - [else (values max-area vc)]))) - (when (max-area . <= . 3) (return (list v1 v2))) - - ;(plot3d-subdivisions (+ (plot3d-subdivisions) 1)) - (append (subdivide-line v1 vc (- depth 1)) - (rest (subdivide-line vc v2 (- depth 1)))))) - - (define (subdivide-lines vs) - (append - (append* - (for/list ([v1 (in-list vs)] [v2 (in-list (rest vs))]) - (define line-vs (subdivide-line v1 v2)) - (take line-vs (sub1 (length line-vs))))) - (list (last vs)))) - - (define (subdivide-polygon vs) - (subdivide-lines (cons (last vs) vs))) - - ; shapes + ;; Drawing shapes (define/public (put-line v1 v2 [c (vcenter (list v1 v2))]) (let/ec return @@ -835,7 +802,7 @@ (add-shape! (line alpha (plot->view/no-rho c) (plot->view v1) (plot->view v2) pen-color pen-width pen-style))] [else - (define vs (map plot->view (subdivide-line v1 v2))) + (define vs (map plot->view (subdivide-line plot->dc* v1 v2))) (for ([v1 (in-list vs)] [v2 (in-list (rest vs))]) (add-shape! (line alpha (plot->view/no-rho c) v1 v2 pen-color pen-width pen-style)))])))) @@ -857,7 +824,7 @@ clip-y-min clip-y-max clip-z-min clip-z-max) vs)] - [vs (map plot->view (if identity-transforms? vs (subdivide-polygon vs)))]) + [vs (map plot->view (if identity-transforms? vs (subdivide-polygon plot->dc* vs)))]) (when (empty? vs) (return lst)) (cons (polygon (get-alpha) (plot->view/no-rho c) vs norm (get-pen-color) (get-pen-width) (get-pen-style) diff --git a/collects/plot/plot3d/isosurface.rkt b/collects/plot/plot3d/isosurface.rkt index c765d5b1c3..e43e49ae40 100644 --- a/collects/plot/plot3d/isosurface.rkt +++ b/collects/plot/plot3d/isosurface.rkt @@ -173,7 +173,7 @@ (define ((polar3d-render-proc f g samples color line-color line-width line-style alpha label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) (match-define (3d-sample xs ys zs dsss d-min d-max) - (f x-min x-max (animated-samples samples) + (g x-min x-max (animated-samples samples) y-min y-max (animated-samples samples) z-min z-max (animated-samples samples))) diff --git a/collects/plot/plot3d/plot.rkt b/collects/plot/plot3d/plot.rkt index fa1bdabbe8..5303e771bb 100644 --- a/collects/plot/plot3d/plot.rkt +++ b/collects/plot/plot3d/plot.rkt @@ -95,7 +95,7 @@ (send area start-renderer rx-min rx-max ry-min ry-max rz-min rz-max) (if render-proc (render-proc area) empty)))) - (send area end-plot) + (send area end-renderers) (when (and (not (empty? legend-entries)) (or (not (plot-animating?)) @@ -104,7 +104,7 @@ (when (plot-animating?) (send area draw-angles)) - (send area restore-drawing-params))) + (send area end-plot))) ;; =================================================================================================== ;; Plot to various other backends diff --git a/collects/plot/plot3d/surface.rkt b/collects/plot/plot3d/surface.rkt index 555f69a3e2..928b8dcf3d 100644 --- a/collects/plot/plot3d/surface.rkt +++ b/collects/plot/plot3d/surface.rkt @@ -12,8 +12,8 @@ (define ((surface3d-render-proc f samples color style line-color line-width line-style alpha label) area) (define-values (x-min x-max y-min y-max z-min z-max) (send area get-bounds)) - (match-define (list xs ys zss) (f x-min x-max (animated-samples samples) - y-min y-max (animated-samples samples))) + (match-define (2d-sample xs ys zss fz-min fz-max) (f x-min x-max (animated-samples samples) + y-min y-max (animated-samples samples))) (send area put-alpha alpha) (send area put-brush color style) diff --git a/collects/plot/tests/tick-tests.rkt b/collects/plot/tests/tick-tests.rkt index 3d9db7a207..7b5bc77358 100644 --- a/collects/plot/tests/tick-tests.rkt +++ b/collects/plot/tests/tick-tests.rkt @@ -134,7 +134,8 @@ [plot-z-far-label "z far axis"] [plot-z-far-ticks (currency-ticks)] [plot-z-far-max-ticks 5]) - (plot3d (surface3d (λ (x y) (+ (sin x) (cos y))) -2 2 -2 2 #:alpha 1/2))) + (plot3d (surface3d (λ (x y) (+ (sin x) (cos y))) -2 2 -2 2 #:alpha 1/2) + #:angle 60 #:altitude 35)) (parameterize ([plot-title "Saddle"] [plot-x-axis? #f]