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

Refactoring: plot-device% now uses dc<%>'s set-origin, simplifying uses

Browse Source
This commit is contained in:
Neil Toronto 2011-11-22 21:45:25 -07:00
parent 700765abb2
commit 57f07d516d
7 changed files with 78 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/plot/common/legend.rkt
View File

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

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

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

8
collects/plot/common/snip.rkt
View File

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

3
collects/plot/contracted/legend.rkt
View File

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

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

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

20
collects/plot/plot2d/snip.rkt
View File

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

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

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