1#lang typed/racket/base 2 3;; Instances of this class know how to draw points, polygons, rectangles, lines, text, a bunch of 4;; different "glyphs" (used for point symbols and ticks), and legends on their underlying device 5;; contexts. Drawing functions accept vectors representing dc coordinates. 6 7;; It is up to callers to transform view or plot coordinates into dc coordinates. 8 9(require typed/racket/draw 10 typed/racket/class 11 (only-in typed/pict pict pict? pict-width pict-height pict-descent pict-ascent) 12 racket/match racket/math racket/bool racket/list racket/vector 13 "draw-attribs.rkt" 14 "color-map.rkt" 15 "draw.rkt" 16 "math.rkt" 17 "sample.rkt" 18 "parameters.rkt" 19 "legend.rkt" 20 "types.rkt" 21 (only-in "contract.rkt" known-point-symbols)) 22 23(provide plot-device% 24 Tick-Params 25 Label-Params) 26 27(: coord->cons (-> (Vectorof Real) (Pair Real Real))) 28(define (coord->cons v) 29 (match-define (vector x y) v) 30 (cons x y)) 31 32(: translate-glyph-sym+size (-> Point-Sym Nonnegative-Real (Values Point-Sym Nonnegative-Real))) 33(define (translate-glyph-sym+size sym size) 34 (let ([sym (if (integer? sym) (remainder (abs sym) 128) sym)]) 35 (case sym 36 [(0) (values 'square size)] 37 [(1) (values 'dot size)] 38 [(2) (values 'plus size)] 39 [(3) (values 'asterisk size)] 40 [(4) (values 'circle size)] 41 [(5) (values 'times size)] 42 [(6) (values 'square size)] 43 [(7) (values 'triangle size)] 44 [(8) (values 'oplus size)] 45 [(9) (values 'odot size)] 46 [(10) (values '4star size)] 47 [(11) (values 'diamond size)] 48 [(12) (values '5star size)] 49 [(13) (values 'square size)] 50 [(14) (values 'circle (* 9/12 size))] 51 [(15) (values '6star size)] 52 [(16) (values 'fullsquare size)] 53 [(17) (values 'fullcircle (* 4/6 size))] 54 [(18) (values 'full5star size)] 55 [(19) (values 'square size)] 56 [(20 circle1) (values 'circle (* 3/6 size))] 57 [(21 circle2) (values 'circle (* 4/6 size))] 58 [(22 circle3) (values 'circle (* 5/6 size))] 59 [(23 circle4) (values 'circle size)] 60 [(24 circle5) (values 'circle (* 8/6 size))] 61 [(25 circle6) (values 'circle (* 12/6 size))] 62 [(26 circle7) (values 'circle (* 14/6 size))] 63 [(27 circle8) (values 'circle (* 18/6 size))] 64 [(28) (values 'leftarrow size)] 65 [(29) (values 'rightarrow size)] 66 [(30) (values 'uparrow size)] 67 [(31) (values 'downarrow size)] 68 [(fullcircle1) (values 'fullcircle (* 3/6 size))] 69 [(bullet fullcircle2) (values 'fullcircle (* 4/6 size))] 70 [(fullcircle3) (values 'fullcircle (* 5/6 size))] 71 [(fullcircle4) (values 'fullcircle size)] 72 [(fullcircle5) (values 'fullcircle (* 8/6 size))] 73 [(fullcircle6) (values 'fullcircle (* 12/6 size))] 74 [(fullcircle7) (values 'fullcircle (* 14/6 size))] 75 [(fullcircle8) (values 'fullcircle (* 18/6 size))] 76 [else (cond [(and (integer? sym) (<= 32 sym 127)) 77 (values (bytes->string/utf-8 (bytes sym)) size)] 78 [(char? sym) 79 (values (list->string (list sym)) size)] 80 [else 81 (values sym size)])]))) 82 83(: full-glyph-hash (HashTable Point-Sym Point-Sym)) 84(define full-glyph-hash 85 #hash((fullcircle . circle) 86 (fullsquare . square) 87 (fulldiamond . diamond) 88 (fulltriangle . triangle) 89 (fulltriangleup . triangleup) 90 (fulltriangledown . triangledown) 91 (fulltriangleleft . triangleleft) 92 (fulltriangleright . triangleright) 93 (full4star . 4star) 94 (full5star . 5star) 95 (full6star . 6star) 96 (full7star . 7star) 97 (full8star . 8star))) 98 99(define-type Tick-Params (List Boolean (Vectorof Real) Real Real)) 100(define-type Label-Params (List (U #f String pict) (Vectorof Real) Anchor Real)) 101 102(: plot-device% Plot-Device%) 103(define plot-device% 104 (class object% 105 (init-field dc dc-x-min dc-y-min dc-x-size dc-y-size) 106 107 (super-new) 108 109 ;; =============================================================================================== 110 ;; Drawing parameters 111 112 (define: old-scale-x : Real 0) 113 (define: old-scale-y : Real 0) 114 (let-values ([(x y) (send dc get-scale)]) 115 (set! old-scale-x x) 116 (set! old-scale-y y)) 117 118 (define: old-origin-x : Real 0) 119 (define: old-origin-y : Real 0) 120 (let-values ([(x y) (send dc get-origin)]) 121 (set! old-origin-x x) 122 (set! old-origin-y y)) 123 124 (: old-smoothing (U 'aligned 'unsmoothed 'smoothed)) 125 (: old-text-mode (U 'transparent 'solid)) 126 (: old-clipping-region (U #f (Instance Region%))) 127 (: old-font (Instance Font%)) 128 (: old-text-foreground (Instance Color%)) 129 (: old-pen (Instance Pen%)) 130 (: old-brush (Instance Brush%)) 131 (: old-background (Instance Color%)) 132 (: old-alpha Nonnegative-Real) 133 134 (define old-smoothing (send dc get-smoothing)) 135 (define old-text-mode (send dc get-text-mode)) 136 (define old-clipping-region (send dc get-clipping-region)) 137 (define old-font (send dc get-font)) 138 (define old-text-foreground (send dc get-text-foreground)) 139 (define old-pen (send dc get-pen)) 140 (define old-brush (send dc get-brush)) 141 (define old-background (send dc get-background)) 142 (define old-alpha (send dc get-alpha)) 143 144 (define/public (restore-drawing-params) 145 (send dc set-origin old-origin-x old-origin-y) 146 (send dc set-smoothing old-smoothing) 147 (send dc set-text-mode old-text-mode) 148 (send dc set-clipping-region old-clipping-region) 149 (send dc set-font old-font) 150 (send dc set-text-foreground old-text-foreground) 151 (send dc set-pen old-pen) 152 (send dc set-brush old-brush) 153 (send dc set-background old-background) 154 (send dc set-alpha old-alpha)) 155 156 (define/public (reset-drawing-params [clipping-rect? #t]) 157 (send dc set-origin 158 (+ old-origin-x (* old-scale-x dc-x-min)) 159 (+ old-origin-y (* old-scale-y dc-y-min))) 160 (send dc set-smoothing 'smoothed) 161 (send dc set-text-mode 'transparent) 162 (when clipping-rect? 163 (send dc set-clipping-rect 0 0 dc-x-size dc-y-size)) 164 (set-font-attribs (plot-font-size) (plot-font-face) (plot-font-family)) 165 (set-text-foreground (plot-foreground)) 166 (set-pen (plot-foreground) (plot-line-width) 'solid) 167 (set-brush (plot-background) 'solid) 168 (set-background (plot-background)) 169 (set-background-alpha (plot-background-alpha)) 170 (set-alpha (plot-foreground-alpha))) 171 172 ;; ----------------------------------------------------------------------------------------------- 173 ;; Pen, brush, alpha parameters 174 175 (define pen-hash ((inst make-hash (Vector Integer Integer Integer Real) (Instance Pen%)))) 176 (define transparent-pen (make-pen% 0 0 0 1 'transparent 'round)) 177 178 (: pen-color (List Real Real Real)) 179 (: pen-width Nonnegative-Real) 180 (: pen-style Plot-Pen-Style-Sym) 181 (define pen-color (->pen-color (plot-foreground))) 182 (define pen-width (plot-line-width)) 183 (define pen-style 'solid) 184 185 ;; Sets the pen, using a hash table to avoid making duplicate objects. At time of writing (and for 186 ;; the forseeable future) this is much faster than using a pen-list%, because it doesn't have to 187 ;; synchronize access. It's also not thread-safe. 188 (define/public (set-pen color width style [cap 'round]) 189 (set! pen-style (->pen-style style)) 190 (cond [(eq? pen-style 'transparent) 191 (set! pen-color '(0 0 0)) 192 (set! pen-width 1) 193 (send dc set-pen transparent-pen)] 194 [else 195 (set! pen-color (->pen-color color)) 196 (set! pen-width width) 197 (match-define (list (app real->color-byte r) 198 (app real->color-byte g) 199 (app real->color-byte b)) 200 pen-color) 201 (send dc set-pen (hash-ref! pen-hash (vector r g b width) 202 (λ () (make-pen% r g b width 'solid cap))))])) 203 204 ;; Sets the pen used to draw major ticks. 205 (define/public (set-major-pen [style 'solid]) 206 (set-pen (plot-foreground) (plot-line-width) style)) 207 208 ;; Sets the pen used to draw minor ticks. 209 (define/public (set-minor-pen [style 'solid]) 210 (set-pen (plot-foreground) (* 1/2 (plot-line-width)) style)) 211 212 (define brush-hash ((inst make-hash (Vector Integer Integer Integer Symbol) (Instance Brush%)))) 213 (define transparent-brush (make-brush% 0 0 0 'transparent)) 214 215 (: brush-style Brush-Style) 216 (: brush-color (List Real Real Real)) 217 (define brush-style 'solid) 218 (define brush-color (->brush-color (plot-background))) 219 220 ;; Sets the brush. Same idea as set-pen. 221 (define/public (set-brush color style) 222 (set! brush-style (->brush-style style)) 223 (cond [(eq? brush-style 'transparent) 224 (set! brush-color '(0 0 0)) 225 (send dc set-brush transparent-brush)] 226 [else 227 (set! brush-color (->brush-color color)) 228 (match-define (list (app real->color-byte r) 229 (app real->color-byte g) 230 (app real->color-byte b)) 231 brush-color) 232 (send dc set-brush (hash-ref! brush-hash (vector r g b brush-style) 233 (λ () (make-brush% r g b brush-style))))])) 234 235 ;; Sets alpha. 236 (define/public (set-alpha a) 237 (send dc set-alpha a)) 238 239 ;; Sets the background color. 240 (define/public (set-background color) 241 (send dc set-background (color->color% (->brush-color color)))) 242 243 (: background-alpha Nonnegative-Real) 244 (define background-alpha 1) 245 246 ;; Sets the background opacity. 247 (define/public (set-background-alpha alpha) 248 (set! background-alpha alpha)) 249 250 ;; ----------------------------------------------------------------------------------------------- 251 ;; Text parameters 252 253 (define/public (set-font font) 254 (send dc set-font font)) 255 256 ;; Sets the font, using the-font-list to cache fonts. 257 (define/public (set-font-attribs size face family) 258 (send dc set-font 259 (if face 260 (send the-font-list find-or-create-font 261 (real->font-size size) 262 face 263 family 264 'normal 265 'normal) 266 (send the-font-list find-or-create-font 267 (real->font-size size) 268 family 269 'normal 270 'normal)))) 271 272 ;; Sets only the font size, not the face or family. 273 (define/public (set-font-size size) 274 (set-font-attribs size 275 (send (send dc get-font) get-face) 276 (send (send dc get-font) get-family))) 277 278 ;; Returns the character height, as an exact real. 279 (define/public (get-char-height) 280 (inexact->exact (send dc get-char-height))) 281 282 ;; Returns the character baseline, as an exact real. 283 (define/public (get-char-baseline) 284 (define-values (_1 _2 b _3) (get-text-extent "")) 285 (inexact->exact b)) 286 287 ;; Returns the extent of a string, as exact reals. 288 (define/public (get-text-extent str) 289 (define-values (w h b d) 290 (cond ((string? str) 291 (send dc get-text-extent str #f #t 0)) 292 ((pict? str) 293 (values (pict-width str) (pict-height str) 294 (pict-descent str) (pict-ascent str))) 295 (#t 296 (values 0 0 0 0)))) 297 (values (inexact->exact w) (inexact->exact h) 298 (inexact->exact b) (inexact->exact d))) 299 300 ;; Returns the width of a string, as an exact real. 301 (define/public (get-text-width str) 302 (define-values (w _1 _2 _3) (get-text-extent str)) 303 (inexact->exact w)) 304 305 ;; Sets the text foreground color. 306 (define/public (set-text-foreground color) 307 (send dc set-text-foreground (color->color% (->pen-color color)))) 308 309 310 ;; ----------------------------------------------------------------------------------------------- 311 ;; Arrows 312 313 (: pd-arrow-head-size-or-scale (U (List '= Nonnegative-Real) Nonnegative-Real)) 314 (: pd-arrow-head-angle Nonnegative-Real) 315 (define pd-arrow-head-size-or-scale (arrow-head-size-or-scale)) 316 (define pd-arrow-head-angle (arrow-head-angle)) 317 318 ;; Sets the arrow-head shape (for draw-arrow) 319 (define/public (set-arrow-head size-or-scale angle) 320 (set! pd-arrow-head-size-or-scale size-or-scale) 321 (set! pd-arrow-head-angle angle)) 322 323 324 ;; ----------------------------------------------------------------------------------------------- 325 ;; Clipping 326 327 ;; Sets a clipping rectangle 328 (define/public (set-clipping-rect r) 329 (cond [(rect-rational? r) 330 (match-define (vector (ivl x1 x2) (ivl y1 y2)) r) 331 (cond [(and x1 x2 y1 y2) 332 (send dc set-clipping-rect x1 y1 (abs (- x2 x1)) (abs (- y2 y1)))] 333 [else 334 (raise-argument-error 'set-clipping-rect "rect-known?" r)])] 335 [else 336 (raise-argument-error 'set-clipping-rect "rect-rational?" r)])) 337 338 ;; Clears the clipping rectangle. 339 (define/public (clear-clipping-rect) 340 (send dc set-clipping-region #f)) 341 342 ;; Derived classes both do manual clipping against plot bounds (instead of dc bounds). 343 344 ;; =============================================================================================== 345 ;; Drawing primitives 346 347 (define/public (clear) 348 (define old-alpha (send dc get-alpha)) 349 (send dc set-alpha background-alpha) 350 (send dc clear) 351 (send dc set-alpha old-alpha)) 352 353 (define/public (draw-point v) 354 (when (vrational? v) 355 (match-define (vector x y) v) 356 (send dc draw-point x y))) 357 358 (define/public (draw-polygon vs) 359 (when (andmap vrational? vs) 360 (let ([vs (map coord->cons vs)]) 361 (cond [(eq? pen-style 'transparent) 362 (send dc set-smoothing 'unsmoothed) 363 (send dc draw-polygon vs 0 0 'winding) 364 (send dc set-smoothing 'smoothed)] 365 [else 366 (define old-pen (send dc get-pen)) 367 (send dc set-pen transparent-pen) 368 (send dc set-smoothing 'unsmoothed) 369 (send dc draw-polygon vs 0 0 'winding) 370 (send dc set-smoothing 'smoothed) 371 (send dc set-pen old-pen) 372 (draw-lines/pen-style dc (cons (last vs) vs) pen-style)])))) 373 374 (define/public (draw-rect r) 375 (when (rect-rational? r) 376 (match-define (vector (ivl x1 x2) (ivl y1 y2)) r) 377 (cond [(and x1 x2 y1 y2) 378 (draw-polygon (list (vector x1 y1) (vector x1 y2) (vector x2 y2) (vector x2 y1)))] 379 [else 380 (raise-argument-error 'draw-rect "rect-known?" r)]))) 381 382 (define/public (draw-lines vs) 383 (when (andmap vrational? vs) 384 (draw-lines/pen-style dc (map coord->cons vs) pen-style))) 385 386 (define/public (draw-line v1 v2) 387 (when (and (vrational? v1) (vrational? v2)) 388 (match-define (vector x1 y1) v1) 389 (match-define (vector x2 y2) v2) 390 (draw-line/pen-style dc x1 y1 x2 y2 pen-style))) 391 392 (define/public (draw-text str v [anchor 'top-left] [angle 0] [dist 0] [outline? #f]) 393 (when (vrational? v) 394 (match-define (vector x y) v) 395 396 (when outline? 397 ;(define alpha (send dc get-alpha)) 398 (define fg (send dc get-text-foreground)) 399 400 ;(send dc set-alpha (alpha-expt alpha 1/2)) 401 (send dc set-text-foreground (send dc get-background)) 402 (for* ([dx (list -1 0 1)] 403 [dy (list -1 0 1)] 404 #:when (not (and (zero? dx) (zero? dy)))) 405 (draw-text/anchor dc str (+ x dx) (+ y dy) anchor angle dist)) 406 ;(send dc set-alpha alpha) 407 (send dc set-text-foreground fg)) 408 409 (draw-text/anchor dc str x y anchor angle dist))) 410 411 (define/public (get-text-corners str v [anchor 'top-left] [angle 0] [dist 0]) 412 (cond [(vrational? v) 413 (match-define (vector x y) v) 414 (map (λ ([v : (Vectorof Real)]) 415 (match-define (vector x y) v) 416 (vector (ann (inexact->exact x) Real) (ann (inexact->exact y) Real))) 417 (get-text-corners/anchor dc str x y anchor angle dist))] 418 [else empty])) 419 420 (define/public (draw-arrow v1 v2) 421 (when (and (vrational? v1) (vrational? v2)) 422 (match-define (vector x1 y1) v1) 423 (match-define (vector x2 y2) v2) 424 (define dx (- x2 x1)) 425 (define dy (- y2 y1)) 426 (define angle (if (and (zero? dy) (zero? dx)) 0 (atan dy dx))) 427 (define dist (sqrt (+ (sqr dx) (sqr dy)))) 428 (define head-r 429 (let ([size-or-scale pd-arrow-head-size-or-scale]) 430 (if (list? size-or-scale) 431 (cadr size-or-scale) 432 (* size-or-scale dist)))) 433 (define dx1 (* (cos (+ angle pd-arrow-head-angle)) head-r)) 434 (define dy1 (* (sin (+ angle pd-arrow-head-angle)) head-r)) 435 (define dx2 (* (cos (- angle pd-arrow-head-angle)) head-r)) 436 (define dy2 (* (sin (- angle pd-arrow-head-angle)) head-r)) 437 (send dc draw-line x1 y1 x2 y2) 438 (send dc draw-line x2 y2 (- x2 dx1) (- y2 dy1)) 439 (send dc draw-line x2 y2 (- x2 dx2) (- y2 dy2)))) 440 441 ;; ----------------------------------------------------------------------------------------------- 442 ;; Glyph (point sym) primitives 443 444 (: make-draw-circle-glyph (-> Nonnegative-Real (-> (Vectorof Real) Void))) 445 (define/private ((make-draw-circle-glyph r) v) 446 (when (vrational? v) 447 (match-define (vector x y) v) 448 (send dc draw-ellipse (- x r -1/2) (- y r -1/2) (* 2 r) (* 2 r)))) 449 450 (: make-draw-polygon-glyph (-> Nonnegative-Real Natural Real (-> (Vectorof Real) Void))) 451 (define/private (make-draw-polygon-glyph r sides start-angle) 452 (define angles (linear-seq start-angle (+ start-angle (* 2 pi)) (+ 1 sides))) 453 (λ (v) 454 (when (vrational? v) 455 (match-define (vector x y) v) 456 (send dc draw-polygon (map (λ ([a : Real]) 457 (cons (+ x (* (cos a) r)) (+ y (* (sin a) r)))) 458 angles))))) 459 460 (: make-draw-star-glyph (-> Real Natural Real (-> (Vectorof Real) Void))) 461 (define/private (make-draw-star-glyph r sides start-angle) 462 (define angles (linear-seq start-angle (+ start-angle (* 2 pi)) (+ 1 (* 2 sides)))) 463 (λ (v) 464 (when (vrational? v) 465 (match-define (vector x y) v) 466 (define pts 467 (for/list : (Listof (Pair Real Real)) ([a (in-list angles)] [i (in-naturals)]) 468 (define r-cos-a (* r (cos a))) 469 (define r-sin-a (* r (sin a))) 470 (cond [(odd? i) (cons (+ x r-cos-a) (+ y r-sin-a))] 471 [else (cons (+ x (* 1/2 r-cos-a)) (+ y (* 1/2 r-sin-a)))]))) 472 (send dc draw-polygon pts)))) 473 474 (: make-draw-flare-glyph (-> Real Natural Real (-> (Vectorof Real) Void))) 475 (define/private (make-draw-flare-glyph r sticks start-angle) 476 (define step (/ (* 2 pi) sticks)) 477 (define angles (build-list sticks (λ ([n : Index]) (+ start-angle (* n step))))) 478 (λ (v) 479 (when (vrational? v) 480 (match-define (vector x y) v) 481 (for ([a (in-list angles)]) 482 (send dc draw-line x y (+ x (* (cos a) r)) (+ y (* (sin a) r))))))) 483 484 (define/public (get-tick-endpoints v r angle) 485 (match-define (vector x y) v) 486 (define dx (* (inexact->exact (cos angle)) r)) 487 (define dy (* (inexact->exact (sin angle)) r)) 488 (list (vector (- x dx) (- y dy)) (vector (+ x dx) (+ y dy)))) 489 490 (define/public (draw-tick v r angle) 491 (when (vrational? v) 492 (match-define (vector x y) v) 493 (define dx (* (cos angle) r)) 494 (define dy (* (sin angle) r)) 495 (send dc draw-line (- x dx) (- y dy) (+ x dx) (+ y dy)))) 496 497 (: make-draw-arrow-glyph (-> Real Real (-> (Vectorof Real) Void))) 498 (define/private (make-draw-arrow-glyph r angle) 499 (define head-r (* 4/5 r)) 500 (define head-angle (* 1/6 pi)) 501 (define dx (* (cos angle) r)) 502 (define dy (* (sin angle) r)) 503 (define dx1 (* (cos (+ angle head-angle)) head-r)) 504 (define dy1 (* (sin (+ angle head-angle)) head-r)) 505 (define dx2 (* (cos (- angle head-angle)) head-r)) 506 (define dy2 (* (sin (- angle head-angle)) head-r)) 507 (λ (v) 508 (when (vrational? v) 509 (match-define (vector x y) v) 510 (define head-x (+ x dx)) 511 (define head-y (+ y dy)) 512 (define tail-x (- x dx)) 513 (define tail-y (- y dy)) 514 (send dc draw-line head-x head-y tail-x tail-y) 515 (send dc draw-line head-x head-y (- head-x dx1) (- head-y dy1)) 516 (send dc draw-line head-x head-y (- head-x dx2) (- head-y dy2))))) 517 518 (define/public (draw-arrow-glyph v r angle) 519 ((make-draw-arrow-glyph r angle) v)) 520 521 (: make-draw-text-glyph (-> String (-> (Vectorof Real) Void))) 522 (define/private (make-draw-text-glyph str) 523 (define-values (x-size y-size _1 _2) (get-text-extent str)) 524 (define dx (* 1/2 x-size)) 525 (define dy (* 1/2 y-size)) 526 (λ (v) 527 (when (vrational? v) 528 (match-define (vector x y) v) 529 (send dc draw-text str (- x dx) (- y dy) #t)))) 530 531 (: mix-draw-glyph (-> (-> (Vectorof Real) Void) 532 (-> (Vectorof Real) Void) 533 (-> (Vectorof Real) Void))) 534 (define/private ((mix-draw-glyph d1 d2) v) 535 (d1 v) 536 (d2 v)) 537 538 (define/public (draw-glyphs vs sym size) 539 (let-values ([(real-sym size) (translate-glyph-sym+size sym size)]) 540 (define draw-glyph 541 (cond 542 [(string? real-sym) (set-font-size (* 2 size)) 543 (set-text-foreground pen-color) 544 (make-draw-text-glyph real-sym)] 545 [(symbol? real-sym) 546 (define r (* 1/2 size)) 547 (define line-sym 548 (cond [(hash-has-key? full-glyph-hash real-sym) 549 (when (eq? pen-color brush-color) 550 (set-pen pen-color 1 'transparent) 551 (set-brush brush-color 'solid)) 552 (hash-ref full-glyph-hash real-sym)] 553 [else (set-brush brush-color 'transparent) 554 real-sym])) 555 (case line-sym 556 [(none) void] 557 ; circles 558 [(circle) (make-draw-circle-glyph r)] 559 ; squares 560 [(square) (make-draw-polygon-glyph r 4 (* 1/4 pi))] 561 [(diamond) (make-draw-polygon-glyph r 4 0)] 562 ; triangles 563 [(triangle 564 triangleup) (make-draw-polygon-glyph r 3 (* -1/2 pi))] 565 [(triangledown) (make-draw-polygon-glyph r 3 (* 1/2 pi))] 566 [(triangleleft) (make-draw-polygon-glyph r 3 pi)] 567 [(triangleright) (make-draw-polygon-glyph r 3 0)] 568 ; dots 569 [(point pixel dot) (set-pen pen-color (* 1/2 r) 'solid) 570 (λ ([v : (Vectorof Real)]) (draw-point v))] 571 [(odot) (set-pen pen-color 1 'solid) 572 (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) 573 (λ (v) (draw-point v)))] 574 ; flares 575 [(plus) (make-draw-flare-glyph r 4 0)] 576 [(times) (make-draw-flare-glyph r 4 (* 1/4 pi))] 577 [(5asterisk) (make-draw-flare-glyph r 5 (* -1/2 pi))] 578 [(asterisk) (make-draw-flare-glyph r 6 (* -1/2 pi))] 579 [(oplus) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) 580 (make-draw-flare-glyph r 4 0))] 581 [(otimes) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) 582 (make-draw-flare-glyph r 4 (* 1/4 pi)))] 583 [(o5asterisk) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) 584 (make-draw-flare-glyph r 5 (* -1/2 pi)))] 585 [(oasterisk) (mix-draw-glyph (make-draw-circle-glyph (+ pen-width r)) 586 (make-draw-flare-glyph r 6 (* -1/2 pi)))] 587 ; arrows 588 [(rightarrow) (make-draw-arrow-glyph (+ 1 r) 0)] 589 [(leftarrow) (make-draw-arrow-glyph (+ 1 r) pi)] 590 [(uparrow) (make-draw-arrow-glyph (+ 1 r) (* -1/2 pi))] 591 [(downarrow) (make-draw-arrow-glyph (+ 1 r) (* 1/2 pi))] 592 ; stars 593 [(3star) (make-draw-star-glyph (+ 1 r) 3 (* 1/2 pi))] 594 [(4star) (make-draw-star-glyph (+ 1 r) 4 (* 1/2 pi))] 595 [(5star) (make-draw-star-glyph (+ 1 r) 5 (* 1/2 pi))] 596 [(6star) (make-draw-star-glyph (+ 1 r) 6 (* 1/2 pi))] 597 [(7star) (make-draw-star-glyph (+ 1 r) 7 (* 1/2 pi))] 598 [(8star) (make-draw-star-glyph (+ 1 r) 8 (* 1/2 pi))] 599 [else (raise-type-error 'draw-glyphs (format "one of ~a" known-point-symbols) sym)])] 600 [else (raise-type-error 'draw-glyphs "integer, character, string or symbol" sym)])) 601 602 (for ([v (in-list vs)]) 603 (draw-glyph v)))) 604 605 (define/public (draw-pict pict v [anchor 'top-left] [dist 0]) 606 (when (vrational? v) 607 (match-define (vector x y) v) 608 (draw-pict/anchor dc pict x y anchor dist))) 609 610 ;; =============================================================================================== 611 ;; Legend 612 613 ;; the folowing functions take a (Listof legend-entry), a Rect and Anchor as argument. 614 ;; the understanding is that Rect will be the complete dc for a legend outside the plot-area 615 ;; and the plot-area otherwise 616 617 (: calculate-legend-parameters (-> (Listof legend-entry) Rect Anchor 618 (Values Rect (Listof Exact-Rational) 619 Nonnegative-Exact-Rational (Listof Real) (Listof Real) 620 Nonnegative-Exact-Rational (Listof Real) 621 Boolean Nonnegative-Integer))) 622 (define/private (calculate-legend-parameters legend-entries rect legend-anchor) 623 (define n (length legend-entries)) 624 (define labels (map legend-entry-label legend-entries)) 625 (match-define (vector (ivl x-min x-max) (ivl y-min y-max)) rect) 626 (cond 627 [(and x-min x-max y-min y-max) 628 (define-values (cols? rows cols compact?) 629 (match (plot-legend-layout) 630 [(list 'rows i compact) 631 (values #f (min n i) (ceiling (/ n i)) (equal? compact 'compact))] 632 [(list 'columns i compact) 633 (values #t (ceiling (/ n i)) (min n i) (equal? compact 'compact))])) 634 (define div (if cols? rows cols)) 635 636 ;; get max widths and heights per row/column 637 (define-values (max-label-widths max-label-heights) 638 (let-values ([(width height) 639 (for/fold ([width : (HashTable Integer Exact-Rational) #hash()] 640 [height : (HashTable Integer Exact-Rational) #hash()]) 641 ([label (in-list labels)] 642 [k (in-naturals)]) 643 (define-values (i j) 644 (let-values ([(i j) (quotient/remainder k div)]) 645 (if cols? (values j i) (values i j)))) 646 (define-values (w h b a) (get-text-extent label)) 647 (values 648 (hash-update width j (λ ([v : Exact-Rational]) (max w v)) (λ () 0)) 649 (hash-update height i (λ ([v : Exact-Rational]) (max h v)) (λ () 0))))]) 650 (define widths 651 ((inst map Exact-Rational (Pairof Integer Exact-Rational)) 652 cdr ((inst sort (Pairof Integer Exact-Rational)) 653 (hash->list width) < #:key car))) 654 (define heights 655 ((inst map Exact-Rational (Pairof Integer Exact-Rational)) 656 cdr ((inst sort (Pairof Integer Exact-Rational)) 657 (hash->list height) < #:key car))) 658 (cond 659 [compact? (values widths heights)] 660 [else 661 (define max-width (apply max widths)) 662 (define max-heights (apply max heights)) 663 (values (map (λ (_) max-width) widths) 664 (map (λ (_) max-heights) heights))]))) 665 666 ;; different gaps 667 (define-values (horiz-gap min-label-height baseline _1) 668 (get-text-extent " ")) 669 670 (define top-gap baseline) 671 (define bottom-gap (* 1/2 baseline)) 672 (define in-label-gap (* 3 horiz-gap)) 673 (define column-gap (* 3 in-label-gap)) 674 675 ;; size of legend line/square 676 (define draw-y-size (max 0 (- min-label-height baseline))) 677 (define draw-x-size (* 4 draw-y-size)) 678 679 ;; size of complete legend-entry 680 (define x-skips (for/list : (Listof Exact-Rational) 681 ([w (in-list max-label-widths)]) 682 (+ w in-label-gap draw-x-size column-gap))) 683 (define y-skips (for/list : (Listof Exact-Rational) 684 ([h (in-list max-label-heights)]) 685 (+ h baseline))) 686 687 ;; size of complete legend 688 (define legend-x-size (+ horiz-gap (- column-gap) horiz-gap 689 (for/sum : Exact-Rational ([w (in-list x-skips)]) w))) 690 (define legend-y-size (+ top-gap bottom-gap 691 (for/sum : Exact-Rational ([h (in-list y-skips)]) h))) 692 693 ;; top-left corner of legend 694 (define legend-x-min 695 (case legend-anchor 696 [(top-left left bottom-left auto) x-min] 697 [(top-right right bottom-right) (- x-max legend-x-size)] 698 [(center bottom top) (- (* 1/2 (+ x-min x-max)) 699 (* 1/2 legend-x-size))])) 700 701 (define legend-y-min 702 (case legend-anchor 703 [(top-left top top-right auto) y-min] 704 [(bottom-left bottom bottom-right) (- y-max legend-y-size)] 705 [(center left right) (- (* 1/2 (+ y-min y-max)) 706 (* 1/2 legend-y-size))])) 707 708 (define legend-rect (vector (ivl legend-x-min (+ legend-x-min legend-x-size)) 709 (ivl legend-y-min (+ legend-y-min legend-y-size)))) 710 711 ;; per entry x/y left/top corners 712 (define label-x-mins (for/fold ([mins : (Listof Real) (list (+ legend-x-min horiz-gap))] 713 [prev : Real (+ legend-x-min horiz-gap)] 714 #:result (reverse mins)) 715 ([x (in-list x-skips)]) 716 (define nxt (+ prev x)) 717 (values (cons nxt mins) nxt))) 718 (define label-y-mins (for/fold ([mins : (Listof Real) (list (+ legend-y-min top-gap))] 719 [prev : Real (+ legend-y-min top-gap)] 720 #:result (reverse mins)) 721 ([y (in-list y-skips)]) 722 (define nxt (+ prev y)) 723 (values (cons nxt mins) nxt))) 724 (define draw-x-mins (for/list : (Listof Real) 725 ([x (in-list label-x-mins)] 726 [w (in-list max-label-widths)]) (+ x w in-label-gap))) 727 728 (values legend-rect max-label-heights 729 draw-x-size label-x-mins draw-x-mins 730 draw-y-size label-y-mins 731 cols? div)] 732 [else 733 (raise-argument-error 'draw-legend "rect-known?" 1 legend-entries rect)])) 734 735 (define/public (calculate-legend-rect legend-entries rect legend-anchor) 736 ;; Change font for correct size calculation in calculate-legend-parameters 737 (define old-size (send (send dc get-font) get-point-size)) 738 (define old-face (send (send dc get-font) get-face)) 739 (define old-family (send (send dc get-font) get-family)) 740 (set-font-attribs 741 (or (plot-legend-font-size) old-size) 742 (or (plot-legend-font-face) old-face) 743 (or (plot-legend-font-family) old-family)) 744 745 (define-values (legend-rect max-label-heights 746 draw-x-size label-x-mins draw-x-mins 747 draw-y-size label-y-mins 748 cols? div) 749 (calculate-legend-parameters legend-entries rect legend-anchor)) 750 751 ;; Undo change font 752 (set-font-attribs old-size old-face old-family) 753 754 legend-rect) 755 756 (define/public (draw-legend legend-entries rect) 757 (define legend-anchor (plot-legend-anchor)) 758 (when (not (eq? legend-anchor 'no-legend)) 759 (match-define (list (legend-entry #{labels : (Listof (U String pict))} 760 #{draw-procs : (Listof Legend-Draw-Proc)}) 761 ...) 762 legend-entries) 763 764 ;; Change font early for correct size calculation in calculate-legend-parameters 765 (define old-size (send (send dc get-font) get-point-size)) 766 (define old-face (send (send dc get-font) get-face)) 767 (define old-family (send (send dc get-font) get-family)) 768 (set-font-attribs 769 (or (plot-legend-font-size) old-size) 770 (or (plot-legend-font-face) old-face) 771 (or (plot-legend-font-family) old-family)) 772 773 (define-values (legend-rect max-label-heights 774 draw-x-size label-x-mins draw-x-mins 775 draw-y-size label-y-mins 776 cols? div) 777 (calculate-legend-parameters legend-entries rect (legend-anchor->anchor legend-anchor))) 778 779 ;; legend background 780 (set-pen (plot-foreground) 1 'transparent) 781 (set-brush (plot-background) 'solid) 782 (set-alpha (plot-legend-box-alpha)) 783 (draw-rect legend-rect) 784 785 ;; legend border 786 (set-minor-pen) 787 (set-brush (plot-background) 'transparent) 788 (set-alpha 3/4) 789 (draw-rect legend-rect) 790 791 (set-alpha (plot-foreground-alpha)) 792 (set-clipping-rect legend-rect) 793 (for ([label (in-list labels)] [draw-proc (in-list draw-procs)] [k (in-naturals)]) 794 (define-values (i j) 795 (let-values ([(i j) (quotient/remainder k div)]) 796 (if cols? (values j i) (values i j)))) 797 798 (define-values (_1 label-height _2 _3) (get-text-extent label)) 799 (define label-x-min (list-ref label-x-mins j)) 800 (define legend-entry-y-min (list-ref label-y-mins i)) 801 (define max-label-height (list-ref max-label-heights i)) 802 (define label-y-min (+ legend-entry-y-min 803 (* 1/2 (- max-label-height label-height)))) 804 805 (if (pict? label) 806 (draw-pict label (vector label-x-min label-y-min) 'top-left 0) 807 (draw-text label (vector label-x-min label-y-min) 'top-left 0 0 #t)) 808 809 (define draw-y-min (+ legend-entry-y-min (* 1/2 (- max-label-height draw-y-size)))) 810 (define draw-x-min (list-ref draw-x-mins j)) 811 812 (define entry-pd (make-object plot-device% dc draw-x-min draw-y-min draw-x-size draw-y-size)) 813 (send entry-pd reset-drawing-params #f) 814 (draw-proc this draw-x-size draw-y-size) 815 (send entry-pd restore-drawing-params)) 816 817 ;; reset plot font attributes 818 (set-font-attribs old-size old-face old-family) 819 820 (clear-clipping-rect)) 821 ))) ; end class 822