Small fixes, refactoring
Began finalizing the public interface to plot-device%
This commit is contained in:
Neil Toronto
parent
6bed60452a
commit
d477352c98
|
|
@ -153,36 +153,6 @@
|
|||
(cond [(exact-integer? c) (vector-ref brush-colors (modulo c 128))]
|
||||
[else (->color c)]))
|
||||
|
||||
#|
|
||||
(define pen-colors
|
||||
'#((0 0 0) ; black
|
||||
(128 0 0) ; red
|
||||
(0 96 0) ; green
|
||||
(0 0 160) ; blue
|
||||
(192 96 0) ; yellow
|
||||
(0 112 128) ; cyan
|
||||
(160 32 240) ; magenta
|
||||
(160 160 160))) ; gray
|
||||
|
||||
(defproc (->pen-color [c plot-color/c]) (list/c real? real? real?)
|
||||
(cond [(exact-integer? c) (vector-ref pen-colors (modulo c 8))]
|
||||
[else (->color c)]))
|
||||
|
||||
(define brush-colors
|
||||
'#((255 255 255) ; white
|
||||
(255 192 192) ; red
|
||||
(192 255 192) ; green
|
||||
(212 224 240) ; blue
|
||||
(255 248 192) ; yellow
|
||||
(192 240 255) ; cyan
|
||||
(240 224 255) ; magenta
|
||||
(212 212 212))) ; gray
|
||||
|
||||
(defproc (->brush-color [c plot-color/c]) (list/c real? real? real?)
|
||||
(cond [(exact-integer? c) (vector-ref brush-colors (modulo c 8))]
|
||||
[else (->color c)]))
|
||||
|#
|
||||
|
||||
(defproc (->pen-style [s plot-pen-style/c]) symbol?
|
||||
(cond [(exact-integer? s) (case (remainder (abs s) 5)
|
||||
[(0) 'solid]
|
||||
|
|
@ -321,3 +291,69 @@
|
|||
(return new-left new-right new-top new-bottom))
|
||||
|
||||
(values new-left new-right new-top new-bottom))))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Null device context (used for speed testing)
|
||||
|
||||
(define-syntax-rule (define-public-stubs val name ...)
|
||||
(begin (define/public (name . args) val) ...))
|
||||
|
||||
(define null-dc%
|
||||
(class* object% (dc<%>)
|
||||
(define color (make-object color% 0 0 0))
|
||||
(define font (make-object font% 8 'default))
|
||||
(define pen (make-object pen% color 1 'solid))
|
||||
(define brush (make-object brush% color 'solid))
|
||||
(define matrix (vector 1 0 0 0 1 0))
|
||||
(define transformation (vector matrix 0 0 0 0 0))
|
||||
(define-public-stubs transformation get-transformation)
|
||||
(define-public-stubs matrix get-initial-matrix)
|
||||
(define-public-stubs 'solid get-text-mode)
|
||||
(define-public-stubs color get-text-foreground get-text-background get-background)
|
||||
(define-public-stubs #t get-smoothing ok? start-doc glyph-exists?)
|
||||
(define-public-stubs #f get-clipping-region get-gl-context)
|
||||
(define-public-stubs 0 get-rotation get-char-height get-char-width)
|
||||
(define-public-stubs (values 0 0) get-origin get-scale get-size)
|
||||
(define-public-stubs font get-font)
|
||||
(define-public-stubs pen get-pen)
|
||||
(define-public-stubs brush get-brush)
|
||||
(define-public-stubs 1 get-alpha)
|
||||
(define-public-stubs (values 1 1) get-device-scale)
|
||||
(define-public-stubs (values 0 0 0 0) get-text-extent)
|
||||
(define-public-stubs (void)
|
||||
flush suspend-flush resume-flush
|
||||
start-page end-page end-doc
|
||||
set-transformation
|
||||
set-text-mode
|
||||
set-smoothing
|
||||
set-text-foreground
|
||||
set-text-background
|
||||
set-scale
|
||||
set-rotation
|
||||
set-origin
|
||||
set-initial-matrix
|
||||
set-font
|
||||
set-clipping-region
|
||||
set-clipping-rect
|
||||
set-brush
|
||||
set-pen
|
||||
set-alpha
|
||||
set-background
|
||||
draw-text
|
||||
draw-spline
|
||||
draw-line
|
||||
draw-lines
|
||||
draw-ellipse
|
||||
draw-rectangle
|
||||
draw-rounded-rectangle
|
||||
draw-polygon
|
||||
draw-point
|
||||
draw-path
|
||||
draw-bitmap-section
|
||||
draw-bitmap
|
||||
draw-arc
|
||||
copy clear erase
|
||||
cache-font-metrics-key
|
||||
transform rotate scale translate
|
||||
try-color)
|
||||
(super-new)))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
;; Functions that create legend entries and lists of legend entries.
|
||||
|
||||
(require racket/class racket/match racket/list racket/string racket/sequence racket/contract
|
||||
"math.rkt"
|
||||
"contract.rkt"
|
||||
"contract-doc.rkt"
|
||||
"format.rkt"
|
||||
|
|
@ -19,7 +20,8 @@
|
|||
(defproc (line-legend-entry [label string?]
|
||||
[color plot-color/c] [width (>=/c 0)] [style plot-pen-style/c]
|
||||
) legend-entry?
|
||||
(legend-entry label (λ (pd x-min x-max y-min y-max)
|
||||
(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)))
|
||||
(send pd set-pen color width style)
|
||||
(send pd set-alpha 1)
|
||||
|
|
@ -51,11 +53,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 (λ (pd x-min x-max y-min y-max)
|
||||
(legend-entry label (λ (pd rect)
|
||||
(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)))))
|
||||
(send pd draw-rect rect))))
|
||||
|
||||
(defproc (rectangle-legend-entries [label string?] [zs (listof real?)]
|
||||
[fill-colors plot-colors/c] [fill-styles plot-brush-styles/c]
|
||||
|
|
@ -92,12 +94,13 @@
|
|||
[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 x-min x-max y-min y-max)
|
||||
(legend-entry label (λ (pd rect)
|
||||
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect)
|
||||
(send pd set-alpha 1)
|
||||
;; rectangle
|
||||
(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))
|
||||
(send pd draw-rect rect)
|
||||
;; 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))
|
||||
|
|
@ -173,19 +176,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 x-min x-max y-min y-max)
|
||||
(legend-entry label (λ (pd rect)
|
||||
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect)
|
||||
(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))))
|
||||
(send pd draw-glyphs (list (rect-center rect)) 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 (λ (pd x-min x-max y-min y-max)
|
||||
(legend-entry label (λ (pd rect)
|
||||
(match-define (vector (ivl x-min x-max) y-ivl) rect)
|
||||
(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))))
|
||||
(send pd draw-arrow-glyph (rect-center rect) (* 1/4 (- x-max x-min)) 0))))
|
||||
|
|
|
|||
|
|
@ -465,6 +465,10 @@
|
|||
(match-define (ivl a b) i)
|
||||
(if (and a b) (- b a) #f))
|
||||
|
||||
(defproc (ivl-center [i ivl?]) (or/c real? #f)
|
||||
(match-define (ivl a b) i)
|
||||
(if (and a b) (* 1/2 (+ a b)) #f))
|
||||
|
||||
(defproc (ivl-zero-length? [i ivl?]) boolean?
|
||||
(or (ivl-empty? i) (ivl-singular? i)))
|
||||
|
||||
|
|
@ -571,6 +575,9 @@
|
|||
(when (or (not len) (zero? len)) (break len))
|
||||
(* area (ivl-length i)))))
|
||||
|
||||
(defproc (rect-center [r (vectorof ivl?)]) (vectorof real?)
|
||||
(vector-map ivl-center r))
|
||||
|
||||
(defproc (rect-zero-area? [r (vectorof ivl?)]) boolean?
|
||||
(vector-ormap ivl-zero-length? r))
|
||||
|
||||
|
|
|
|||
|
|
@ -85,73 +85,10 @@
|
|||
(full7star . 7star)
|
||||
(full8star . 8star)))
|
||||
|
||||
(define-syntax-rule (define-public-stubs val name ...)
|
||||
(begin (define/public (name . args) val) ...))
|
||||
|
||||
(define null-dc%
|
||||
(class* object% (dc<%>)
|
||||
(define color (make-object color% 0 0 0))
|
||||
(define font (make-object font% 8 'default))
|
||||
(define pen (make-object pen% color 1 'solid))
|
||||
(define brush (make-object brush% color 'solid))
|
||||
(define matrix (vector 1 0 0 0 1 0))
|
||||
(define transformation (vector matrix 0 0 0 0 0))
|
||||
(define-public-stubs transformation get-transformation)
|
||||
(define-public-stubs matrix get-initial-matrix)
|
||||
(define-public-stubs 'solid get-text-mode)
|
||||
(define-public-stubs color get-text-foreground get-text-background get-background)
|
||||
(define-public-stubs #t get-smoothing ok? start-doc glyph-exists?)
|
||||
(define-public-stubs #f get-clipping-region get-gl-context)
|
||||
(define-public-stubs 0 get-rotation get-char-height get-char-width)
|
||||
(define-public-stubs (values 0 0) get-origin get-scale get-size)
|
||||
(define-public-stubs font get-font)
|
||||
(define-public-stubs pen get-pen)
|
||||
(define-public-stubs brush get-brush)
|
||||
(define-public-stubs 1 get-alpha)
|
||||
(define-public-stubs (values 1 1) get-device-scale)
|
||||
(define-public-stubs (values 0 0 0 0) get-text-extent)
|
||||
(define-public-stubs (void)
|
||||
flush suspend-flush resume-flush
|
||||
start-page end-page end-doc
|
||||
set-transformation
|
||||
set-text-mode
|
||||
set-smoothing
|
||||
set-text-foreground
|
||||
set-text-background
|
||||
set-scale
|
||||
set-rotation
|
||||
set-origin
|
||||
set-initial-matrix
|
||||
set-font
|
||||
set-clipping-region
|
||||
set-clipping-rect
|
||||
set-brush
|
||||
set-pen
|
||||
set-alpha
|
||||
set-background
|
||||
draw-text
|
||||
draw-spline
|
||||
draw-line
|
||||
draw-lines
|
||||
draw-ellipse
|
||||
draw-rectangle
|
||||
draw-rounded-rectangle
|
||||
draw-polygon
|
||||
draw-point
|
||||
draw-path
|
||||
draw-bitmap-section
|
||||
draw-bitmap
|
||||
draw-arc
|
||||
copy clear erase
|
||||
cache-font-metrics-key
|
||||
transform rotate scale translate
|
||||
try-color)
|
||||
(super-new)))
|
||||
|
||||
(define plot-device%
|
||||
(class object%
|
||||
(init-field dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
|
||||
|
||||
;(init-field the-dc dc-x-min dc-y-min dc-x-size dc-y-size)
|
||||
;(define dc (make-object null-dc%))
|
||||
|
||||
|
|
@ -288,15 +225,10 @@
|
|||
;; -----------------------------------------------------------------------------------------------
|
||||
;; Clipping
|
||||
|
||||
;; Sets a clipping rectangle; deals with swapped mins and maxes.
|
||||
(define/public (set-clipping-rect v1 v2)
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(let ([x1 (min x1 x2)]
|
||||
[x2 (max x1 x2)]
|
||||
[y1 (min y1 y2)]
|
||||
[y2 (max y1 y2)])
|
||||
(send dc set-clipping-rect x1 y1 (- x2 x1) (- y2 y1))))
|
||||
;; Sets a clipping rectangle
|
||||
(define/public (set-clipping-rect r)
|
||||
(match-define (vector (ivl x1 x2) (ivl y1 y2)) r)
|
||||
(send dc set-clipping-rect x1 y1 (- x2 x1) (- y2 y1)))
|
||||
|
||||
;; Clears the clipping rectangle.
|
||||
(define/public (clear-clipping-rect)
|
||||
|
|
@ -322,12 +254,10 @@
|
|||
(when (andmap vregular? vs)
|
||||
(send dc draw-polygon (map coord->cons vs) 0 0 fill-style)))
|
||||
|
||||
(define/public (draw-rectangle v1 v2)
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(draw-polygon
|
||||
(list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1)))))
|
||||
(define/public (draw-rect r)
|
||||
(when (rect-regular? r)
|
||||
(match-define (vector (ivl x1 x2) (ivl y1 y2)) r)
|
||||
(draw-polygon (list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1)))))
|
||||
|
||||
(define/public (draw-lines vs)
|
||||
(when (andmap vregular? vs)
|
||||
|
|
@ -544,10 +474,12 @@
|
|||
;; ===============================================================================================
|
||||
;; Legend
|
||||
|
||||
(define/public (draw-legend legend-entries x-min x-max y-min y-max)
|
||||
(define/public (draw-legend legend-entries rect)
|
||||
(define n (length legend-entries))
|
||||
(match-define (list (legend-entry labels draws) ...) legend-entries)
|
||||
|
||||
(match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect)
|
||||
|
||||
(define-values (_1 label-y-size baseline _2) (get-text-extent (first labels)))
|
||||
(define horiz-gap (get-text-width " "))
|
||||
(define top-gap baseline)
|
||||
|
|
@ -581,6 +513,7 @@
|
|||
|
||||
(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 label-x-min (+ legend-x-min horiz-gap))
|
||||
(define draw-x-min (+ legend-x-min (* 2 horiz-gap) labels-x-size horiz-gap))
|
||||
|
|
@ -589,19 +522,20 @@
|
|||
(set-alpha (plot-legend-box-alpha))
|
||||
(set-minor-pen)
|
||||
(set-brush (plot-background) 'solid)
|
||||
(draw-rectangle (vector legend-x-min legend-y-min) (vector legend-x-max legend-y-max))
|
||||
(draw-rect legend-rect)
|
||||
|
||||
(set-clipping-rect (vector legend-x-min legend-y-min) (vector legend-x-max legend-y-max))
|
||||
(set-clipping-rect legend-rect)
|
||||
(for ([label (in-list labels)]
|
||||
[draw (in-list draws)]
|
||||
[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 draw-x-min draw-x-max draw-y-min draw-y-max))
|
||||
(draw this drawing-rect))
|
||||
|
||||
(clear-clipping-rect))
|
||||
)) ; end class
|
||||
|
|
|
|||
|
|
@ -639,6 +639,6 @@
|
|||
(list (tick x #f label))]
|
||||
[(m . = . 1) (filter pre-tick-major? ts)]
|
||||
[else (match-define (list (tick xs _ labels) ...) (filter pre-tick-major? ts))
|
||||
(define x (/ (apply + xs) n))
|
||||
(define x (/ (apply + xs) m))
|
||||
(define label (format format-string (first labels) (last labels)))
|
||||
(list (tick x #t label))])))))
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@
|
|||
[ivl-join (->* () () #:rest (listof ivl?) ivl?)])
|
||||
empty-ivl unknown-ivl
|
||||
(activate-contract-out
|
||||
ivl-empty? ivl-known? ivl-regular? ivl-singular? ivl-length ivl-zero-length?
|
||||
ivl-empty? ivl-known? ivl-regular? ivl-singular? ivl-length ivl-center ivl-zero-length?
|
||||
ivl-inexact->exact ivl-contains? bounds->intervals))
|
||||
|
||||
;; Rectangles
|
||||
|
|
@ -29,5 +29,5 @@
|
|||
[rect-join (->* () () #:rest (listof (vectorof ivl?)) (vectorof ivl?))])
|
||||
(activate-contract-out
|
||||
empty-rect unknown-rect bounding-rect
|
||||
rect-empty? rect-known? rect-regular? rect-area rect-zero-area? rect-singular?
|
||||
rect-empty? rect-known? rect-regular? rect-area rect-center rect-zero-area? rect-singular?
|
||||
rect-inexact->exact rect-contains?))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(require racket/match racket/list)
|
||||
|
||||
(provide point-in-bounds? clip-line clip-rectangle clip-lines clip-polygon)
|
||||
(provide point-in-bounds? clip-line clip-lines clip-polygon)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Point clipping
|
||||
|
|
@ -13,27 +13,6 @@
|
|||
(match-define (vector x y) v)
|
||||
(and (<= x-min x x-max) (<= y-min y y-max)))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Rectangle clipping
|
||||
|
||||
(define (clip-rectangle v1 v2 x-min x-max y-min y-max)
|
||||
(let/ec return
|
||||
; early accept: both endpoints in bounds
|
||||
(when (and (point-in-bounds? v1 x-min x-max y-min y-max)
|
||||
(point-in-bounds? v2 x-min x-max y-min y-max))
|
||||
(return v1 v2))
|
||||
; early reject: both endpoints on the outside of the same plane
|
||||
(match-define (vector x1 y1) v1)
|
||||
(match-define (vector x2 y2) v2)
|
||||
(when (or (and (x1 . < . x-min) (x2 . < . x-min)) (and (x1 . > . x-max) (x2 . > . x-max))
|
||||
(and (y1 . < . y-min) (y2 . < . y-min)) (and (y1 . > . y-max) (y2 . > . y-max)))
|
||||
(return #f #f))
|
||||
(let ([x1 (max (min x1 x-max) x-min)]
|
||||
[x2 (max (min x2 x-max) x-min)]
|
||||
[y1 (max (min y1 y-max) y-min)]
|
||||
[y2 (max (min y2 y-max) y-min)])
|
||||
(values (vector x1 y1) (vector x2 y2)))))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Line clipping
|
||||
|
||||
|
|
|
|||
|
|
@ -47,8 +47,8 @@
|
|||
(define clip-y-min y-min)
|
||||
(define clip-y-max y-max)
|
||||
|
||||
(define (clip-to-bounds rx-min rx-max ry-min ry-max)
|
||||
(set! clipping? #t)
|
||||
(define/public (put-clip-rect rect)
|
||||
(match-define (vector (ivl rx-min rx-max) (ivl ry-min ry-max)) rect)
|
||||
(define cx-min (if rx-min (max* x-min rx-min) x-min))
|
||||
(define cx-max (if rx-max (min* x-max rx-max) x-max))
|
||||
(define cy-min (if ry-min (max* y-min ry-min) y-min))
|
||||
|
|
@ -60,9 +60,10 @@
|
|||
(set! clip-x-min cx-min)
|
||||
(set! clip-x-max cx-max)
|
||||
(set! clip-y-min cy-min)
|
||||
(set! clip-y-max cy-max)))
|
||||
(set! clip-y-max cy-max))
|
||||
(set! clipping? #t))
|
||||
|
||||
(define (clip-to-none) (set! clipping? #f))
|
||||
(define/public (clear-clip-rect) (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)))
|
||||
|
|
@ -312,16 +313,6 @@
|
|||
;; ===============================================================================================
|
||||
;; Plot decoration
|
||||
|
||||
(define (draw-labels)
|
||||
(for ([params (in-list (get-all-label-params))])
|
||||
(send/apply pd draw-text params)))
|
||||
|
||||
(define (draw-ticks)
|
||||
(for ([params (in-list (get-all-tick-params))])
|
||||
(match-define (list major? v r angle) params)
|
||||
(if major? (send pd set-major-pen) (send pd set-minor-pen))
|
||||
(send pd draw-tick v r angle)))
|
||||
|
||||
(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)))
|
||||
|
|
@ -346,37 +337,43 @@
|
|||
(vector area-x-max area-y-min)
|
||||
(vector area-x-max area-y-max)))))
|
||||
|
||||
(define (draw-ticks)
|
||||
(for ([params (in-list (get-all-tick-params))])
|
||||
(match-define (list major? v r angle) params)
|
||||
(if major? (send pd set-major-pen) (send pd set-minor-pen))
|
||||
(send pd draw-tick v r angle)))
|
||||
|
||||
(define (draw-labels)
|
||||
(for ([params (in-list (get-all-label-params))])
|
||||
(send/apply pd draw-text params)))
|
||||
|
||||
;; ===============================================================================================
|
||||
;; Public drawing control (used by plot/dc)
|
||||
|
||||
(define/public (start-plot)
|
||||
(send pd reset-drawing-params)
|
||||
(send pd clear)
|
||||
(draw-title)
|
||||
(draw-axes)
|
||||
(draw-ticks))
|
||||
(draw-ticks)
|
||||
(draw-labels)
|
||||
(send pd set-clipping-rect
|
||||
(vector (ivl (+ 1/2 (- area-x-min (plot-line-width))) (+ area-x-max (plot-line-width)))
|
||||
(ivl (+ 1/2 (- area-y-min (plot-line-width))) (+ area-y-max (plot-line-width))))))
|
||||
|
||||
(define/public (start-renderer rend-bounds-rect)
|
||||
(match-define (vector (ivl rx-min rx-max) (ivl ry-min ry-max)) rend-bounds-rect)
|
||||
(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))
|
||||
(reset-drawing-params)
|
||||
(put-clip-rect rend-bounds-rect))
|
||||
|
||||
(define/public (end-renderers)
|
||||
(send pd clear-clipping-rect)
|
||||
(clip-to-none)
|
||||
(send pd reset-drawing-params)
|
||||
(draw-title)
|
||||
(draw-labels))
|
||||
(clear-clip-rect)
|
||||
(send pd reset-drawing-params))
|
||||
|
||||
(define/public (draw-legend legend-entries)
|
||||
(define gap-size (+ (pen-gap) tick-radius))
|
||||
(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)))
|
||||
(send pd draw-legend legend-entries
|
||||
(vector (ivl (+ area-x-min gap-size) (- area-x-max gap-size))
|
||||
(ivl (+ area-y-min gap-size) (- area-y-max gap-size)))))
|
||||
|
||||
(define/public (end-plot)
|
||||
(send pd restore-drawing-params))
|
||||
|
|
@ -401,6 +398,14 @@
|
|||
(define/public (put-font size family) (send pd set-font size family))
|
||||
(define/public (put-text-foreground color) (send pd set-text-foreground color))
|
||||
|
||||
(define/public (reset-drawing-params)
|
||||
(put-alpha (plot-foreground-alpha))
|
||||
(put-pen (plot-foreground) (plot-line-width) 'solid)
|
||||
(put-brush (plot-background) 'solid)
|
||||
(put-background (plot-background))
|
||||
(put-font (plot-font-size) (plot-font-family))
|
||||
(put-text-foreground (plot-foreground)))
|
||||
|
||||
;; Shapes
|
||||
|
||||
(define/public (put-lines vs)
|
||||
|
|
@ -437,14 +442,10 @@
|
|||
(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))
|
||||
(let-values ([(v1 v2) (if clipping?
|
||||
(clip-rectangle v1 v2 clip-x-min clip-x-max
|
||||
clip-y-min clip-y-max)
|
||||
(values v1 v2))])
|
||||
(when (and v1 v2)
|
||||
(send pd draw-rectangle (plot->dc* v1) (plot->dc* v2))))))
|
||||
(define/public (put-rect r)
|
||||
(when (rect-regular? r)
|
||||
(match-define (vector (ivl x1 x2) (ivl y1 y2)) r)
|
||||
(put-polygon (list (vector x1 y1) (vector x2 y1) (vector x2 y2) (vector x1 y2)))))
|
||||
|
||||
(define/public (put-text str v [anchor 'top-left] [angle 0]
|
||||
#:outline? [outline? #f])
|
||||
|
|
|
|||
|
|
@ -18,8 +18,7 @@
|
|||
(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)))
|
||||
(send area put-rect rect))
|
||||
|
||||
(cond [label (rectangle-legend-entry label color style line-color line-width line-style)]
|
||||
[else empty]))
|
||||
|
|
|
|||
|
|
@ -48,8 +48,8 @@
|
|||
(define clip-z-min z-min)
|
||||
(define clip-z-max z-max)
|
||||
|
||||
(define (clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max)
|
||||
(set! clipping? #t)
|
||||
(define/public (put-clip-rect rect)
|
||||
(match-define (vector (ivl rx-min rx-max) (ivl ry-min ry-max) (ivl rz-min rz-max)) rect)
|
||||
(define cx-min (if rx-min (max* x-min rx-min) x-min))
|
||||
(define cx-max (if rx-max (min* x-max rx-max) x-max))
|
||||
(define cy-min (if ry-min (max* y-min ry-min) y-min))
|
||||
|
|
@ -67,9 +67,10 @@
|
|||
(set! clip-y-min cy-min)
|
||||
(set! clip-y-max cy-max)
|
||||
(set! clip-z-min cz-min)
|
||||
(set! clip-z-max cz-max)))
|
||||
(set! clip-z-max cz-max))
|
||||
(set! clipping? #t))
|
||||
|
||||
(define (clip-to-none) (set! clipping? #f))
|
||||
(define/public (clear-clip-rect) (set! clipping? #f))
|
||||
|
||||
(define (in-bounds? v)
|
||||
(or (not clipping?) (point-in-bounds? v clip-x-min clip-x-max
|
||||
|
|
@ -503,6 +504,9 @@
|
|||
;; Fixpoint margin computation
|
||||
|
||||
(define (get-param-vs/set-view->dc! left right top bottom)
|
||||
;(printf "margins: ~v ~v ~v ~v~n" left right top bottom)
|
||||
;(printf "label params = ~v~n" (get-all-label-params))
|
||||
;(printf "tick params = ~v~n" (get-all-tick-params))
|
||||
(set! view->dc (make-view->dc left right top bottom))
|
||||
(append (append* (map (λ (params) (send/apply pd get-text-corners (rest params)))
|
||||
(get-all-label-params)))
|
||||
|
|
@ -521,17 +525,11 @@
|
|||
;; ===============================================================================================
|
||||
;; Plot decoration
|
||||
|
||||
(define (draw-ticks tick-params)
|
||||
(for ([params (in-list tick-params)])
|
||||
(match-define (list major? v r angle) params)
|
||||
(if major? (send pd set-major-pen) (send pd set-minor-pen))
|
||||
(send pd draw-tick v r angle)))
|
||||
(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)))
|
||||
|
||||
(define (draw-labels label-params)
|
||||
(for ([params (in-list label-params)])
|
||||
(send/apply pd draw-text (rest params) #:outline? (first params))))
|
||||
|
||||
(define (draw-far-axes)
|
||||
(define (draw-back-axes)
|
||||
(when (plot-decorations?)
|
||||
(send pd set-minor-pen)
|
||||
(when (plot-x-axis?)
|
||||
|
|
@ -551,7 +549,7 @@
|
|||
(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-axes)
|
||||
(define (draw-front-axes)
|
||||
(when (plot-decorations?)
|
||||
(send pd set-minor-pen)
|
||||
(when (plot-z-axis?)
|
||||
|
|
@ -563,9 +561,15 @@
|
|||
(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))
|
||||
(send pd draw-text (plot-title) (vector (* 1/2 (+ dc-x-min dc-x-max)) dc-y-min) 'top)))
|
||||
(define (draw-ticks tick-params)
|
||||
(for ([params (in-list tick-params)])
|
||||
(match-define (list major? v r angle) params)
|
||||
(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 pd draw-text (rest params) #:outline? (first params))))
|
||||
|
||||
;; ===============================================================================================
|
||||
;; Delayed drawing
|
||||
|
|
@ -638,23 +642,24 @@
|
|||
(define/public (start-plot)
|
||||
(send pd reset-drawing-params)
|
||||
(send pd clear)
|
||||
(set! render-list empty)
|
||||
(draw-title)
|
||||
(draw-labels (get-back-label-params))
|
||||
(draw-ticks (get-back-tick-params))
|
||||
(draw-far-axes))
|
||||
(draw-back-axes)
|
||||
(send pd set-clipping-rect
|
||||
(vector (ivl (+ 1/2 (- area-x-min (plot-line-width))) (+ area-x-max (plot-line-width)))
|
||||
(ivl (+ 1/2 (- area-y-min (plot-line-width))) (+ area-y-max (plot-line-width)))))
|
||||
(set! render-list empty))
|
||||
|
||||
(define/public (start-renderer rend-bounds-rect)
|
||||
(match-define (vector (ivl rx-min rx-max) (ivl ry-min ry-max) (ivl rz-min rz-max))
|
||||
rend-bounds-rect)
|
||||
(send pd reset-drawing-params)
|
||||
(clip-to-bounds rx-min rx-max ry-min ry-max rz-min rz-max))
|
||||
(reset-drawing-params)
|
||||
(put-clip-rect rend-bounds-rect))
|
||||
|
||||
(define/public (end-renderers)
|
||||
(clear-clip-rect)
|
||||
(draw-shapes render-list)
|
||||
(clip-to-none)
|
||||
(send pd reset-drawing-params)
|
||||
(draw-title)
|
||||
(draw-near-axes)
|
||||
(draw-front-axes)
|
||||
(draw-ticks (get-front-tick-params))
|
||||
(draw-labels (get-front-label-params)))
|
||||
|
||||
|
|
@ -674,7 +679,7 @@
|
|||
(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 draw-rect (vector (ivl box-x-min box-x-max) (ivl box-y-min box-y-max)))
|
||||
|
||||
(send pd set-alpha 1)
|
||||
(send pd draw-text
|
||||
|
|
@ -688,10 +693,9 @@
|
|||
|
||||
(define (draw-legend* legend-entries)
|
||||
(define gap-size (+ (pen-gap) tick-radius))
|
||||
(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)))
|
||||
(send pd draw-legend legend-entries
|
||||
(vector (ivl (+ area-x-min gap-size) (- area-x-max gap-size))
|
||||
(ivl (+ area-y-min gap-size) (- area-y-max gap-size)))))
|
||||
|
||||
(define/public (draw-legend legend-entries) (draw-legend* legend-entries))
|
||||
|
||||
|
|
@ -764,6 +768,14 @@
|
|||
(define (get-font-family) font-family)
|
||||
(define (get-text-foreground) text-foreground)
|
||||
|
||||
(define/public (reset-drawing-params)
|
||||
(put-alpha (plot-foreground-alpha))
|
||||
(put-pen (plot-foreground) (plot-line-width) 'solid)
|
||||
(put-brush (plot-background) 'solid)
|
||||
(put-background (plot-background))
|
||||
(put-font (plot-font-size) (plot-font-family))
|
||||
(put-text-foreground (plot-foreground)))
|
||||
|
||||
;; Drawing shapes
|
||||
|
||||
(define/public (put-line v1 v2 [c (vcenter (list v1 v2))])
|
||||
|
|
@ -829,10 +841,9 @@
|
|||
(text (get-alpha) (plot->view/no-rho v) anchor angle str
|
||||
(get-font-size) (get-font-family) (get-text-foreground)))))
|
||||
|
||||
(define/public (put-box v1 v2 [c (vcenter (list v1 v2))])
|
||||
(when (and (vregular? v1) (vregular? v2))
|
||||
(match-define (vector x1 y1 z1) v1)
|
||||
(match-define (vector x2 y2 z2) v2)
|
||||
(define/public (put-rect r [c (rect-center r)])
|
||||
(when (rect-regular? r)
|
||||
(match-define (vector (ivl x1 x2) (ivl y1 y2) (ivl z1 z2)) r)
|
||||
(put-polygons
|
||||
(list
|
||||
;; Top
|
||||
|
|
|
|||
|
|
@ -17,8 +17,7 @@
|
|||
(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) (ivl z1 z2)) rect)
|
||||
(send area put-box (vector x1 y1 z1) (vector x2 y2 z2)))
|
||||
(send area put-rect rect))
|
||||
|
||||
(cond [label (rectangle-legend-entry label color style line-color line-width line-style)]
|
||||
[else empty]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user