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