From 57f07d516dd17e0963f1f213180a37bf5136c803 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Tue, 22 Nov 2011 21:45:25 -0700 Subject: [PATCH] Refactoring: plot-device% now uses dc<%>'s set-origin, simplifying uses --- collects/plot/common/legend.rkt | 32 +++++++++---------- collects/plot/common/plot-device.rkt | 48 ++++++++++++++++------------ collects/plot/common/snip.rkt | 8 ++--- collects/plot/contracted/legend.rkt | 3 +- collects/plot/plot2d/plot-area.rkt | 31 ++++++++---------- collects/plot/plot2d/snip.rkt | 20 ++++-------- collects/plot/plot3d/plot-area.rkt | 24 ++++++-------- 7 files changed, 78 insertions(+), 88 deletions(-) diff --git a/collects/plot/common/legend.rkt b/collects/plot/common/legend.rkt index 87d96af767..b95855a169 100644 --- a/collects/plot/common/legend.rkt +++ b/collects/plot/common/legend.rkt @@ -20,12 +20,11 @@ (defproc (line-legend-entry [label string?] [color plot-color/c] [width (>=/c 0)] [style plot-pen-style/c] ) legend-entry? - (legend-entry label (λ (pd rect) - (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect) - (define y (* 1/2 (+ y-min y-max))) + (legend-entry label (λ (pd x-size y-size) + (define y (* 1/2 y-size)) (send pd set-pen color width style) (send pd set-alpha 1) - (send pd draw-line (vector x-min y) (vector x-max y))))) + (send pd draw-line (vector 0 y) (vector x-size y))))) (defproc (line-legend-entries [label string?] [zs (listof real?)] [z-labels (listof string?)] [colors (plot-colors/c (listof real?))] @@ -55,11 +54,11 @@ [color plot-color/c] [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 (λ (pd rect) + (legend-entry label (λ (pd x-size y-size) (send pd set-brush color style) (send pd set-pen line-color line-width line-style) (send pd set-alpha 1) - (send pd draw-rect rect)))) + (send pd draw-rect (vector (ivl 0 x-size) (ivl 0 y-size)))))) (defproc (rectangle-legend-entries [label string?] [zs (listof real?)] [colors (plot-colors/c (listof real?))] @@ -99,19 +98,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 (λ (pd rect) - (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect) + (legend-entry label (λ (pd x-size y-size) (send pd set-alpha 1) ;; rectangle (send pd set-pen line-color line-width line-style) (send pd set-brush color style) - (send pd draw-rect rect) + (send pd draw-rect (vector (ivl 0 x-size) (ivl 0 y-size))) ;; bottom line (send pd set-pen line1-color line1-width line1-style) - (send pd draw-line (vector x-min y-max) (vector x-max y-max)) + (send pd draw-line (vector 0 y-size) (vector x-size y-size)) ;; top line (send pd set-pen line2-color line2-width line2-style) - (send pd draw-line (vector x-min y-min) (vector x-max y-min))))) + (send pd draw-line (vector 0 0) (vector x-size 0))))) (defproc (interval-legend-entries [label string?] [ivls (listof ivl?)] [ivl-labels (listof string?)] [colors (plot-colors/c (listof ivl?))] @@ -162,17 +160,17 @@ (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 (λ (pd rect) - (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect) + (legend-entry label (λ (pd x-size y-size) (send pd set-pen color line-width 'solid) (send pd set-alpha 1) - (send pd draw-glyphs (list (rect-center rect)) sym size)))) + (send pd draw-glyphs (list (vector (* 1/2 x-size) (* 1/2 y-size))) sym size)))) (defproc (arrow-legend-entry [label string?] [color plot-color/c] [line-width (>=/c 0)] [line-style plot-pen-style/c] ) legend-entry? - (legend-entry label (λ (pd rect) - (match-define (vector (ivl x-min x-max) y-ivl) rect) + (legend-entry label (λ (pd x-size y-size) (send pd set-pen color line-width line-style) (send pd set-alpha 1) - (send pd draw-arrow-glyph (rect-center rect) (* 1/4 (- x-max x-min)) 0)))) + (send pd draw-arrow-glyph + (vector (* 1/2 x-size) (* 1/2 y-size)) + (* 1/4 x-size) 0)))) diff --git a/collects/plot/common/plot-device.rkt b/collects/plot/common/plot-device.rkt index 3c5c82e2c7..81def5c73c 100644 --- a/collects/plot/common/plot-device.rkt +++ b/collects/plot/common/plot-device.rkt @@ -98,6 +98,8 @@ ;; =============================================================================================== ;; Drawing parameters + (define-values (old-scale-x old-scale-y) (send dc get-scale)) + (define-values (old-origin-x old-origin-y) (send dc get-origin)) (define old-smoothing (send dc get-smoothing)) (define old-text-mode (send dc get-text-mode)) (define old-clipping-region (send dc get-clipping-region)) @@ -109,6 +111,7 @@ (define old-alpha (send dc get-alpha)) (define/public (restore-drawing-params) + (send dc set-origin old-origin-x old-origin-y) (send dc set-smoothing old-smoothing) (send dc set-text-mode old-text-mode) (send dc set-clipping-region old-clipping-region) @@ -120,10 +123,13 @@ (send dc set-alpha old-alpha)) (define/public (reset-drawing-params [clipping-rect? #t]) + (send dc set-origin + (+ old-origin-x (* old-scale-x dc-x-min)) + (+ old-origin-y (* old-scale-y dc-y-min))) (send dc set-smoothing 'smoothed) (send dc set-text-mode 'transparent) (when clipping-rect? - (send dc set-clipping-rect dc-x-min dc-y-min dc-x-size dc-y-size)) + (send dc set-clipping-rect 0 0 dc-x-size dc-y-size)) (set-font (plot-font-size) (plot-font-family)) (set-text-foreground (plot-foreground)) (set-pen (plot-foreground) (plot-line-width) 'solid) @@ -169,11 +175,8 @@ (send dc set-brush (hash-ref! brush-hash (vector r g b style) (λ () (make-brush% r g b style)))))) - (define alpha (plot-foreground-alpha)) - ;; Sets alpha. (define/public (set-alpha a) - (set! alpha a) (send dc set-alpha a)) ;; Sets the background color. @@ -498,7 +501,7 @@ (define/public (draw-legend legend-entries rect) (define n (length legend-entries)) - (match-define (list (legend-entry labels draws) ...) legend-entries) + (match-define (list (legend-entry labels draw-procs) ...) legend-entries) (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect) @@ -533,31 +536,36 @@ [(center left right) (- (* 1/2 (+ y-min y-max)) (* 1/2 legend-y-size))])) - (define legend-x-max (+ legend-x-min legend-x-size)) - (define legend-y-max (+ legend-y-min legend-y-size)) - (define legend-rect (vector (ivl legend-x-min legend-x-max) (ivl legend-y-min legend-y-max))) + (define legend-rect (vector (ivl legend-x-min (+ legend-x-min legend-x-size)) + (ivl legend-y-min (+ legend-y-min legend-y-size)))) (define label-x-min (+ legend-x-min horiz-gap)) (define draw-x-min (+ legend-x-min (* 2 horiz-gap) labels-x-size horiz-gap)) - (define draw-x-max (+ draw-x-min draw-x-size)) - (set-alpha (plot-legend-box-alpha)) - (set-minor-pen) + ;; legend background + (set-pen (plot-foreground) 1 'transparent) (set-brush (plot-background) 'solid) + (set-alpha (plot-legend-box-alpha)) (draw-rect legend-rect) + ;; legend border + (set-minor-pen) + (set-brush (plot-background) 'transparent) + (set-alpha 3/4) + (draw-rect legend-rect) + + (set-alpha (plot-foreground-alpha)) (set-clipping-rect legend-rect) - (for ([label (in-list labels)] - [draw (in-list draws)] - [i (in-naturals)]) + (for ([label (in-list labels)] [draw-proc (in-list draw-procs)] [i (in-naturals)]) (define label-y-min (+ legend-y-min top-gap (* i baseline-skip))) - (define draw-y-min (+ label-y-min (* 1/2 baseline))) - (define draw-y-max (+ draw-y-min draw-y-size)) - (define drawing-rect (vector (ivl draw-x-min draw-x-max) (ivl draw-y-min draw-y-max))) - - (reset-drawing-params) (draw-text label (vector label-x-min label-y-min) #:outline? #t) - (draw this drawing-rect)) + + (define draw-y-min (+ label-y-min (* 1/2 baseline))) + + (define entry-pd (make-object plot-device% dc draw-x-min draw-y-min draw-x-size draw-y-size)) + (send entry-pd reset-drawing-params #f) + (draw-proc this draw-x-size draw-y-size) + (send entry-pd restore-drawing-params)) (clear-clipping-rect)) )) ; end class diff --git a/collects/plot/common/snip.rkt b/collects/plot/common/snip.rkt index c637ee1c55..49131a377a 100644 --- a/collects/plot/common/snip.rkt +++ b/collects/plot/common/snip.rkt @@ -65,10 +65,10 @@ (define box-x-size (apply max line-widths)) (define box-y-size (+ baseline (* (length lines) (+ char-height baseline)))) - (define box-x-min (+ dc-x-min (- x-mid (* 1/2 box-x-size)))) - (define box-x-max (+ dc-x-min (+ x-mid (* 1/2 box-x-size)))) - (define box-y-min (+ dc-y-min (- y-mid (* 1/2 box-y-size)))) - (define box-y-max (+ dc-y-min (+ y-mid (* 1/2 box-y-size)))) + (define box-x-min (- x-mid (* 1/2 box-x-size))) + (define box-x-max (+ x-mid (* 1/2 box-x-size))) + (define box-y-min (- y-mid (* 1/2 box-y-size))) + (define box-y-max (+ y-mid (* 1/2 box-y-size))) (define box-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max))) diff --git a/collects/plot/contracted/legend.rkt b/collects/plot/contracted/legend.rkt index 9b1258b4ad..8b3797143f 100644 --- a/collects/plot/contracted/legend.rkt +++ b/collects/plot/contracted/legend.rkt @@ -6,8 +6,7 @@ "../common/plot-device.rkt") (provide (contract-out (struct legend-entry ([label string?] - [draw ((is-a?/c plot-device%) real? real? real? real? - . -> . void?)]))) + [draw ((is-a?/c plot-device%) real? real? . -> . void?)]))) (activate-contract-out line-legend-entry line-legend-entries rectangle-legend-entry rectangle-legend-entries diff --git a/collects/plot/plot2d/plot-area.rkt b/collects/plot/plot2d/plot-area.rkt index f9feca9e4c..30e3395fb5 100644 --- a/collects/plot/plot2d/plot-area.rkt +++ b/collects/plot/plot2d/plot-area.rkt @@ -29,12 +29,6 @@ (define char-height (send pd get-char-height)) (define half-char-height (* 1/2 char-height)) - (define dc-x-max (+ dc-x-min dc-x-size)) - (define dc-y-max (+ dc-y-min dc-y-size)) - (define title-y-min - (cond [(and (plot-decorations?) (plot-title)) (+ dc-y-min (* 3/2 char-height))] - [else dc-y-min])) - (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) bounds-rect) (define x-size (- x-max x-min)) (define y-size (- y-max y-min)) @@ -101,10 +95,10 @@ (values (ivl-length view-x-ivl) (ivl-length view-y-ivl)))) (define (make-view->dc left right top bottom) - (define area-x-min (+ dc-x-min left)) - (define area-x-max (- dc-x-max right)) - (define area-y-min (+ dc-y-min top)) - (define area-y-max (- dc-y-max bottom)) + (define area-x-min left) + (define area-x-max (- dc-x-size right)) + (define area-y-min top) + (define area-y-max (- dc-y-size bottom)) (define area-per-view-x (/ (- area-x-max area-x-min) view-x-size)) (define area-per-view-y (/ (- area-y-max area-y-min) view-y-size)) (λ (v) @@ -112,8 +106,11 @@ (vector (+ area-x-min (* (- x x-min) area-per-view-x)) (- area-y-max (* (- y y-min) area-per-view-y))))) + (define init-top-margin + (cond [(and (plot-decorations?) (plot-title)) (* 3/2 char-height)] + [else 0])) + ;; Initial view->dc (draws labels and half of every tick off the allotted space on the dc) - (define init-top-margin (- title-y-min dc-y-min)) (set! view->dc (make-view->dc 0 0 init-top-margin 0)) ;; =============================================================================================== @@ -301,13 +298,13 @@ (get-all-tick-params))))) (define-values (left right top bottom) - (margin-fixpoint dc-x-min dc-x-max title-y-min dc-y-max 0 0 init-top-margin 0 + (margin-fixpoint 0 dc-x-size init-top-margin dc-y-size 0 0 init-top-margin 0 get-param-vs/set-view->dc!)) - (define area-x-min (+ dc-x-min left)) - (define area-x-max (- dc-x-max right)) - (define area-y-min (+ dc-y-min top)) - (define area-y-max (- dc-y-max bottom)) + (define area-x-min left) + (define area-x-max (- dc-x-size right)) + (define area-y-min top) + (define area-y-max (- dc-y-size bottom)) (define/public (get-area-bounds-rect) (vector (ivl area-x-min area-x-max) (ivl area-y-min area-y-max))) @@ -333,7 +330,7 @@ (define (draw-title) (when (and (plot-decorations?) (plot-title)) - (send pd 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-size) 0) 'top))) (define (draw-axes) (when (plot-decorations?) diff --git a/collects/plot/plot2d/snip.rkt b/collects/plot/plot2d/snip.rkt index 521218af3d..795ae08c2a 100644 --- a/collects/plot/plot2d/snip.rkt +++ b/collects/plot/plot2d/snip.rkt @@ -128,19 +128,18 @@ (send pd reset-drawing-params #f) (define select-color (get-highlight-background-color)) - (define select-rect (rect-translate rect (vector dc-x-min dc-y-min))) ;; inside selection (send pd set-pen select-color 1 'transparent) (send pd set-brush select-color 'solid) (send pd set-alpha 1/4) - (send pd draw-rect select-rect) + (send pd draw-rect rect) ;; selection border (send pd set-minor-pen) (send pd set-brush select-color 'transparent) (send pd set-alpha 3/4) - (send pd draw-rect select-rect) + (send pd draw-rect rect) ;; format side labels (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) plot-bounds-rect) @@ -164,20 +163,13 @@ (send pd set-alpha 1) - (send pd draw-text new-x-min-str - (vector (+ dc-x-min new-area-x-min) (+ dc-y-min new-area-y-mid)) + (send pd draw-text new-x-min-str (vector new-area-x-min new-area-y-mid) 'center (* 1/2 pi) #:outline? #t) - - (send pd draw-text new-x-max-str - (vector (+ dc-x-min new-area-x-max) (+ dc-y-min new-area-y-mid)) + (send pd draw-text new-x-max-str (vector new-area-x-max new-area-y-mid) 'center (* 1/2 pi) #:outline? #t) - - (send pd draw-text new-y-min-str - (vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-max)) + (send pd draw-text new-y-min-str (vector new-area-x-mid new-area-y-max) 'center #:outline? #t) - - (send pd draw-text new-y-max-str - (vector (+ dc-x-min new-area-x-mid) (+ dc-y-min new-area-y-min)) + (send pd draw-text new-y-max-str (vector new-area-x-mid new-area-y-min) 'center #:outline? #t) (send pd restore-drawing-params))) diff --git a/collects/plot/plot3d/plot-area.rkt b/collects/plot/plot3d/plot-area.rkt index fc0ec55736..259511a52b 100644 --- a/collects/plot/plot3d/plot-area.rkt +++ b/collects/plot/plot3d/plot-area.rkt @@ -30,9 +30,6 @@ (define char-height (send pd get-char-height)) (define half-char-height (* 1/2 char-height)) - (define dc-x-max (+ dc-x-min dc-x-size)) - (define dc-y-max (+ dc-y-min dc-y-size)) - (match-define (vector (ivl x-min x-max) (ivl y-min y-max) (ivl z-min z-max)) bounds-rect) (define x-size (- x-max x-min)) (define y-size (- y-max y-min)) @@ -164,10 +161,10 @@ (values (ivl-length view-x-ivl) (ivl-length view-y-ivl) (ivl-length view-z-ivl)))) (define (make-view->dc left right top bottom) - (define area-x-min (+ dc-x-min left)) - (define area-x-max (- dc-x-max right)) - (define area-y-min (+ dc-y-min top)) - (define area-y-max (- dc-y-max bottom)) + (define area-x-min left) + (define area-x-max (- dc-x-size right)) + (define area-y-min top) + (define area-y-max (- dc-y-size bottom)) (define area-x-mid (* 1/2 (+ area-x-min area-x-max))) (define area-y-mid (* 1/2 (+ area-y-min area-y-max))) (define area-per-view-x (/ (- area-x-max area-x-min) view-x-size)) @@ -554,20 +551,19 @@ (get-all-tick-params))))) (define-values (left right top bottom) - (margin-fixpoint dc-x-min dc-x-max dc-y-min dc-y-max 0 0 init-top-margin 0 - get-param-vs/set-view->dc!)) + (margin-fixpoint 0 dc-x-size 0 dc-y-size 0 0 init-top-margin 0 get-param-vs/set-view->dc!)) - (define area-x-min (+ dc-x-min left)) - (define area-x-max (- dc-x-max right)) - (define area-y-min (+ dc-y-min top)) - (define area-y-max (- dc-y-max bottom)) + (define area-x-min left) + (define area-x-max (- dc-x-size right)) + (define area-y-min top) + (define area-y-max (- dc-y-size bottom)) ;; =============================================================================================== ;; Plot decoration (define (draw-title) (when (and (plot-decorations?) (plot-title)) - (send pd 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-size) 0) 'top))) (define (draw-back-axes) (when (plot-decorations?)