1#lang typed/racket/base
2
3;; Extra drawing functions.
4
5(require typed/racket/draw typed/racket/class racket/match racket/list typed/pict
6         (except-in math/base sum)
7         (except-in math/flonum flsum)
8         "math.rkt"
9         "utils.rkt"
10         "types.rkt")
11
12(provide (all-defined-out))
13
14;; ===================================================================================================
15;; Drawing text rotated around an anchor point
16
17(define sin45 (/ 1.0 (sqrt 2.0)))
18
19(: get-box-corners/anchor (->* [Real Real Real Real]
20                               [Anchor Real Real]
21                               (Listof (Vector Real Real))))
22(define (get-box-corners/anchor x y width height [anchor 'top-left] [angle 0] [dist 0])
23  (let ([dist  (case anchor
24                 [(top-left bottom-left top-right bottom-right)  (* sin45 dist)]
25                 [else  dist])])
26    (: dxs (Listof Real))
27    (define dxs (case anchor
28                  [(top-left left bottom-left)  (list (- dist) (- width dist))]
29                  [(top center bottom)          (list (* -1/2 width) (* 1/2 width))]
30                  [else                         (list (- dist width) dist)]))
31    (: dys (Listof Real))
32    (define dys (case anchor
33                  [(top-left top top-right)  (list (- dist) (- height dist))]
34                  [(left center right)       (list (* -1/2 height) (* 1/2 height))]
35                  [else                      (list (- dist height) dist)]))
36
37    (for*/list : (Listof (Vector Real Real)) ([dx  (in-list dxs)] [dy  (in-list dys)])
38      (define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
39      (define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
40      (vector (+ x rdx) (+ y rdy)))))
41
42(: resolve-auto-anchor/str (-> (Instance DC<%>) String Real Real Real Real Anchor))
43(define (resolve-auto-anchor/str dc str x y angle dist)
44  (define region (send dc get-clipping-region))
45  (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0))
46  (if region
47      (let loop ([anchors '(bottom-left bottom-right top-left top-right)]
48                 [best : Anchor 'bottom-left]
49                 [best-score -1])
50        (if (null? anchors)
51            best
52            (let* ((anchor (car anchors))
53                   (corners (get-box-corners/anchor x y width height anchor angle dist))
54                   (center (let ((center-sum (foldl
55                                              (lambda ([corner : (Vector Real Real)] [sum : (Vector Real Real)])
56                                                (match-define (vector x y) corner)
57                                                (match-define (vector sx sy) sum)
58                                                (vector (+ x sx) (+ y sy)))
59                                              (cast (vector 0 0) (Vector Real Real))
60                                              corners)))
61                             (match-define (vector x y) center-sum)
62                             (define ncorners (length corners))
63                             (vector (/ x ncorners) (/ y ncorners))))
64                   (candidates (cons center corners))
65                   (score (foldl
66                           (lambda ([corner : (Vector Real Real)] [score : Integer])
67                             (match-define (vector x y) corner)
68                             (+ (if (send region in-region? x y) 1 0) score))
69                           0
70                           candidates)))
71              (cond
72                ;; All candidate points are visible, don't bother checking
73                ;; other anchor locations
74                ((= score (length candidates)) anchor)
75                ((> score best-score) (loop (cdr anchors) anchor score))
76                (#t (loop (cdr anchors) best best-score))))))
77      'bottom-left))
78
79(: resolve-auto-anchor/pict (-> (Instance DC<%>) pict Real Real Real Anchor))
80(define (resolve-auto-anchor/pict dc pict x y dist)
81  (define region (send dc get-clipping-region))
82  (if region
83      (let ()
84        (define-values (left top width height) (send region get-bounding-box))
85        (define anchor-right? (> (+ x dist (pict-width pict)) (+ left width)))
86        (define anchor-top? (< (- y dist (pict-height pict)) top))
87        (if anchor-right?
88            (if anchor-top? 'top-right 'bottom-right)
89            (if anchor-top? 'top-left 'bottom-left)))
90      'bottom-left))
91
92(: draw-text/anchor (->* [(Instance DC<%>) String Real Real]
93                         [Anchor Real Real]
94                         Void))
95(define (draw-text/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0])
96  (define-values (width height _1 _2) (send dc get-text-extent str #f #t 0))
97  (define nanchor (if (eq? anchor 'auto)
98                      (resolve-auto-anchor/str dc str x y angle dist)
99                      anchor))
100  (let ([dist  (case nanchor
101                 [(top-left bottom-left top-right bottom-right)  (* sin45 dist)]
102                 [else  dist])])
103    (define dx (case nanchor
104                 [(top-left left bottom-left auto)     (- dist)]
105                 [(top center bottom)             (* 1/2 width)]
106                 [(top-right right bottom-right)  (+ width dist)]
107                 [else  (raise-type-error 'draw-text/anchor "anchor/c" anchor)]))
108    (define dy (case nanchor
109                 [(top-left top top-right auto)      (- dist)]
110                 [(left center right)                (* 1/2 height)]
111                 [(bottom-left bottom bottom-right)  (+ height dist)]))
112    (define rdx (+ (* (sin angle) dy) (* (cos angle) dx)))
113    (define rdy (- (* (cos angle) dy) (* (sin angle) dx)))
114
115    (send dc draw-text str (- x rdx) (- y rdy) #t 0 angle)))
116
117(: get-text-corners/anchor (->* [(Instance DC<%>) (U String pict) Real Real]
118                                [Anchor Real Real]
119                                (Listof (Vector Real Real))))
120(define (get-text-corners/anchor dc str x y [anchor 'top-left] [angle 0] [dist 0])
121  (define-values (width height _1 _2)
122    (if (string? str)
123        (send dc get-text-extent str #f #t 0)
124        (values (pict-width str) (pict-height str) 0 0)))
125  (define nanchor (if (eq? anchor 'auto)
126                      (if (string? str)
127                          (resolve-auto-anchor/str dc str x y angle dist)
128                          (resolve-auto-anchor/pict dc str x y dist))
129                      anchor))
130  (get-box-corners/anchor x y width height nanchor angle dist))
131
132(: draw-pict/anchor (->* [(Instance DC<%>) pict Real Real] [Anchor Real] Void))
133(define (draw-pict/anchor dc pict x y [anchor 'top-left] [dist 0])
134  (define width (pict-width pict))
135  (define height (pict-height pict))
136  (define nanchor (if (eq? anchor 'auto)
137                      (resolve-auto-anchor/pict dc pict x y dist)
138                      anchor))
139  (define dx (case nanchor
140               [(top-left left bottom-left auto) (- dist)]
141               [(top center bottom) (* 1/2 width)]
142               [(top-right right bottom-right) (+ width dist)]
143               [else  (raise-type-error 'draw-text/anchor "anchor/c" anchor)]))
144  (define dy (case nanchor
145               [(top-left top top-right auto) (- dist)]
146               [(left center right) (* 1/2 height)]
147               [(bottom-left bottom bottom-right) (+ height dist)]))
148  (draw-pict pict dc (- x dx) (- y dy)))
149
150;; ===================================================================================================
151;; Subdividing nonlinearly transformed shapes
152
153(define subdivide-fracs '(3/7 4/7 2/7 5/7 1/7 6/7))
154
155(: subdivide-line (-> (-> (Vectorof Real) (Vectorof Real)) (Vectorof Real) (Vectorof Real)
156                      (Listof (Vectorof Real))))
157(define (subdivide-line transform v1 v2)
158  (let loop ([v1 v1] [v2 v2] [depth 10])
159    (let/ec return : (Listof (Vectorof Real))
160      (when (zero? depth) (return (list v1 v2)))
161
162      (define dc-v1 (transform v1))
163      (define dc-v2 (transform v2))
164      (define dc-dv (v- dc-v2 dc-v1))
165      (when ((vmag dc-dv) . <= . 3)
166        (return (list v1 v2)))
167
168      (define dv (v- v2 v1))
169      (define-values (max-area vc)
170        (for/fold ([max-area : Real  0] [vc : (Vectorof Real)  v1])
171                  ([frac  (in-list subdivide-fracs)])
172          (define test-vc (v+ (v* dv frac) v1))
173          (define test-area (abs (vcross2 dc-dv (v- (transform test-vc) dc-v1))))
174          (cond [(test-area . > . max-area)  (values test-area test-vc)]
175                [else  (values max-area vc)])))
176      (when (max-area . <= . 3) (return (list v1 v2)))
177
178      ;(plot3d-subdivisions (+ (plot3d-subdivisions) 1))
179      (append (loop v1 vc (- depth 1))
180              (rest (loop vc v2 (- depth 1)))))))
181
182(: subdivide-lines (-> (-> (Vectorof Real) (Vectorof Real)) (Listof (Vectorof Real))
183                       (Listof (Vectorof Real))))
184(define (subdivide-lines transform vs)
185  (append
186   (append*
187    (for/list : (Listof (Listof (Vectorof Real))) ([v1  (in-list vs)] [v2  (in-list (rest vs))])
188      (define line-vs (subdivide-line transform v1 v2))
189      (drop-right line-vs 1)))
190   (list (last vs))))
191
192(: subdivide-polygon
193   (All (L) (case-> (-> (-> (Vectorof Real) (Vectorof Real)) (Listof (Vectorof Real))
194                        (Listof (Vectorof Real)))
195                    (-> (-> (Vectorof Real) (Vectorof Real))
196                        (Listof (Vectorof Real))
197                        (Listof L)
198                        (Values (Listof (Vectorof Real))
199                                (Listof L))))))
200(define subdivide-polygon
201  (case-lambda
202    [(transform vs)
203     (reverse
204      (for/fold ([vs : (Listof (Vectorof Real))  empty])
205                ([v1  (in-list (cons (last vs) vs))]
206                 [v2  (in-list vs)])
207        (define line-vs (rest (subdivide-line transform v1 v2)))
208        (append (reverse line-vs) vs)))]
209    [(transform vs ls)
210     (define-values (new-vs new-ls)
211       (for/fold ([vs : (Listof (Vectorof Real))  empty]
212                  [ls : (Listof L)  empty])
213                 ([v1  (in-list (cons (last vs) vs))]
214                  [v2  (in-list vs)]
215                  [l   (in-list ls)])
216         (define line-vs (rest (subdivide-line transform v1 v2)))
217         (values (append (reverse line-vs) vs)
218                 (append (make-list (length line-vs) l) ls))))
219     (values (reverse new-vs)
220             (reverse new-ls))]))
221
222;; ===================================================================================================
223;; Fixpoint margin computation
224
225;; In calculating margins in 2d-plot-area% and 3d-plot-area%, we have a mutual dependence problem:
226;; 1. We can't set the margins without knowing where the ticks and axis labels will be drawn.
227;; 2. We can't determine the tick and label angles (and thus their vertexes) without the margins.
228
229;; The margins could be solved exactly using algebra and trigonometry, but the solutions wouldn't
230;; be robust, as small changes to the layout algorithms would invalidate them.
231
232;; So we use a fixpoint solution: iterate
233;; 1. Getting tick and label vertexes ('get-vs' below); then
234;; 2. Calculating new margins by how far off the dc the vertexes would be.
235
236;; As long as this process is monotone and bounded, the distance off the dc is zero in the limit. In
237;; practice, only a few iterations drives this distance to less than 1 drawing unit.
238
239(: margin-fixpoint (-> Real Real Real Real Real Real Real Real
240                       (-> Real Real Real Real (Listof (Vectorof Real)))
241                       (Values Real Real Real Real)))
242(define (margin-fixpoint x-min x-max y-min y-max
243                         init-left init-right init-top init-bottom
244                         get-vs)
245  (define x- (+ x-min init-left))
246  (define x+ (- x-max init-right 1))
247  (define y- (+ y-min init-top))
248  (define y+ (- y-max init-bottom 1))
249  (let/ec return : (Values Real Real Real Real)
250    (for/fold ([left   : Real  init-left]
251               [right  : Real  init-right]
252               [top    : Real  init-top]
253               [bottom : Real  init-bottom])
254              ([i  (in-range 3)])
255      (match-define (list (vector #{xs : (Listof Real)} #{ys : (Listof Real)}) ...)
256        (get-vs left right top bottom))
257      (define param-x-min (apply min x- xs))
258      (define param-x-max (apply max x+ xs))
259      (define param-y-min (apply min y- ys))
260      (define param-y-max (apply max y+ ys))
261
262      (define new-left   (round (+ left   (- x- param-x-min))))
263      (define new-right  (round (- right  (- x+ param-x-max))))
264      (define new-top    (round (+ top    (- y- param-y-min))))
265      (define new-bottom (round (- bottom (- y+ param-y-max))))
266
267      ;; Not enough space?
268      (define area-x-min (+ x-min new-left))
269      (define area-x-max (- x-max new-right))
270      (define area-y-min (+ y-min new-top))
271      (define area-y-max (- y-max new-bottom))
272      (when (or (area-x-min . > . area-x-max)
273                (area-y-min . > . area-y-max))
274        (return init-left init-right init-top init-bottom))
275
276      ;; Early out: if the margins haven't changed much, another iteration won't change them more
277      ;; (hopefully)
278      (when (and (= left new-left) (= right new-right)
279                 (= top new-top) (= bottom new-bottom))
280        (return new-left new-right new-top new-bottom))
281
282      (values new-left new-right new-top new-bottom))))
283
284;; ===================================================================================================
285;; Origin-neutral pen styles
286
287(struct pen-style ([length : Flonum] [ps : (Listof Flonum)]) #:transparent)
288
289(: make-pen-style (-> (Listof Natural) pen-style))
290(define (make-pen-style diff-ps)
291  (let* ([diff-ps  (map fl diff-ps)]
292         [diff-ps  (if (even? (length diff-ps)) diff-ps (append diff-ps diff-ps))])
293    (define ps (map fl (cumulative-sum diff-ps)))
294    (define len (last ps))
295    (pen-style len ps)))
296
297(define long-dash-pen-style (make-pen-style '(5 4)))
298(define short-dash-pen-style (make-pen-style '(3 2)))
299(define dot-pen-style (make-pen-style '(1 2)))
300(define dot-dash-pen-style (make-pen-style '(1 3 4 3)))
301
302(: scale-pen-style (-> pen-style Real pen-style))
303(define (scale-pen-style sty scale)
304  (let ([scale  (fl scale)])
305    (match-define (pen-style len ps) sty)
306    (pen-style (* scale len) (map (λ ([p : Flonum]) (fl* scale p)) ps))))
307
308(: cons-fl (-> (Pair Real Real) (Pair Flonum Flonum)))
309(define (cons-fl v)
310  (match-define (cons x1 y1) v)
311  (cons (fl x1) (fl y1)))
312
313(: cons-fl= (-> (Pair Flonum Flonum) (Pair Flonum Flonum) Boolean))
314(define (cons-fl= v1 v2)
315  (match-define (cons x1 y1) v1)
316  (match-define (cons x2 y2) v2)
317  (and (= x1 x2) (= y1 y2)))
318
319(: segment-reverse (All (A) (-> (Listof (Listof A)) (Listof (Listof A)))))
320(define (segment-reverse seg)
321  (reverse (map (inst reverse A) seg)))
322
323(: segment-join (All (A) (-> (Listof (Listof A)) (Listof (Listof A)) (Listof (Listof A)))))
324(define (segment-join s1 s2)
325  (let ([s1  (drop-right s1 1)]
326        [a  (last s1)]
327        [b  (first s2)]
328        [s2  (rest s2)])
329    (append s1 (list (append a (rest b))) s2)))
330
331(: join-styled-segments (-> (Listof (Listof (Listof (Pair Flonum Flonum))))
332                            (Listof (Listof (Listof (Pair Flonum Flonum))))))
333(define (join-styled-segments segments)
334  (let ([segments  (filter (compose not empty?) segments)])
335    (if (empty? segments)
336        empty
337        (match-let ([(cons current-segment segments)  segments])
338          (let loop ([current-segment current-segment] [segments segments])
339            (cond [(empty? segments)  (list current-segment)]
340                  [else
341                   (define lst (last (last current-segment)))
342                   (match-let ([(cons segment segments)  segments])
343                     (define fst (first (first segment)))
344                     (if (cons-fl= lst fst)
345                         (loop ((inst segment-join (Pair Flonum Flonum)) current-segment segment)
346                               segments)
347                         (cons current-segment (loop segment segments))))]))))))
348
349(: styled-segment* (-> Flonum Flonum Flonum Flonum pen-style (-> Flonum Flonum (Pair Flonum Flonum))
350                       (Listof (Listof (Pair Flonum Flonum)))))
351(define (styled-segment* x1 y1 x2 y2 sty pair)
352  (match-define (pen-style len (cons p rest-ps)) sty)
353  (define start-x (* len (floor (/ x1 len))))
354  (define m (/ (- y2 y1) (- x2 x1)))
355  (define b (- y1 (* m x1)))
356  (let loop ([xa start-x]
357             [base-x 0.0]
358             [ps rest-ps]
359             [on? #t]
360             [res : (Listof (Listof (Pair Flonum Flonum)))  empty])
361    (let-values ([(base-x ps)  (cond [(empty? ps)  (values (+ base-x len) rest-ps)]
362                                     [else         (values base-x ps)])])
363      (cond [(xa . fl>= . x2)  (reverse res)]
364            [else
365             (match-let ([(cons p ps)  ps])
366               (define xb (+ start-x (+ p base-x)))
367               (cond [(and on? (xb . fl>= . x1))
368                      (define v (let ([xa  (max x1 xa)]
369                                      [xb  (min x2 xb)])
370                                  (define ya (if (= x1 xa) y1 (+ (* m xa) b)))
371                                  (define yb (if (= x2 xb) y2 (+ (* m xb) b)))
372                                  (list (pair xa ya) (pair xb yb))))
373                      (loop xb base-x ps (not on?) (cons v res))]
374                     [else  (loop xb base-x ps (not on?) res)]))]))))
375
376(: styled-segment (-> Flonum Flonum Flonum Flonum pen-style (Listof (Listof (Pair Flonum Flonum)))))
377(define (styled-segment x1 y1 x2 y2 sty)
378  (define dx (abs (- x2 x1)))
379  (define dy (abs (- y2 y1)))
380  (cond [(and (= dx 0.0) (= dy 0.0))  (list (list (cons x1 y1) (cons x2 y2)))]
381        [(dx . > . dy)
382         (define reverse? (x1 . fl> . x2))
383         (let-values ([(x1 y1)  (if reverse? (values x2 y2) (values x1 y1))]
384                      [(x2 y2)  (if reverse? (values x1 y1) (values x2 y2))])
385           (define segment (styled-segment* x1 y1 x2 y2 sty cons))
386           (if reverse? (segment-reverse segment) segment))]
387        [else
388         (define reverse? (y1 . fl> . y2))
389         (let-values ([(x1 y1)  (if reverse? (values x2 y2) (values x1 y1))]
390                      [(x2 y2)  (if reverse? (values x1 y1) (values x2 y2))])
391           (define segment (styled-segment* y1 x1 y2 x2 sty (λ (y x) (cons x y))))
392           (if reverse? (segment-reverse segment) segment))]))
393
394(: symbol->style (-> (U 'dot 'long-dash 'short-dash 'dot-dash) pen-style))
395(define (symbol->style style-sym)
396  (case style-sym
397    [(long-dash)   long-dash-pen-style]
398    [(short-dash)  short-dash-pen-style]
399    [(dot)         dot-pen-style]
400    [(dot-dash)    dot-dash-pen-style]))
401
402(: draw-line/pen-style (-> (Instance DC<%>) Real Real Real Real Plot-Pen-Style-Sym Void))
403(define (draw-line/pen-style dc x1 y1 x2 y2 style-sym)
404  (case style-sym
405    [(transparent)  (void)]
406    [(solid)        (send dc draw-line x1 y1 x2 y2)]
407    [else
408     (let ([x1  (fl x1)] [y1  (fl y1)] [x2  (fl x2)] [y2  (fl y2)])
409       (define sty (symbol->style style-sym))
410       (define pen (send dc get-pen))
411       (define scale (max 1.0 (fl (send pen get-width))))
412       (define vss (styled-segment x1 y1 x2 y2 (scale-pen-style sty scale)))
413       (for ([vs  (in-list vss)] #:when (not (empty? vs)))
414         (match-define (list (cons xa ya) (cons xb yb)) vs)
415         (send dc draw-line xa ya xb yb)))]))
416
417(: draw-lines* (-> (Instance DC<%>) (Listof (Pair Flonum Flonum)) pen-style Void))
418(define (draw-lines* dc vs sty)
419  (define vss
420    (append* (join-styled-segments
421              (for/list ([v1  (in-list vs)] [v2  (in-list (rest vs))])
422                (match-define (cons x1 y1) v1)
423                (match-define (cons x2 y2) v2)
424                (styled-segment x1 y1 x2 y2 sty)))))
425  (for ([vs  (in-list vss)])
426    (match vs
427      [(list (cons x1 y1) (cons x2 y2))  (send dc draw-line x1 y1 x2 y2)]
428      [_  (send dc draw-lines vs)])))
429
430(: draw-lines/pen-style (-> (Instance DC<%>) (Listof (Pair Real Real)) Plot-Pen-Style-Sym Void))
431(define (draw-lines/pen-style dc vs style-sym)
432  (cond [(or (empty? vs) (eq? style-sym 'transparent))  (void)]
433        [else
434         (let ([vs  (map cons-fl vs)])
435           (cond [(eq? style-sym 'solid)  (send dc draw-lines vs)]
436                 [else
437                  (define pen (send dc get-pen))
438                  (define scale (max 1.0 (fl (send pen get-width))))
439                  (define sty (scale-pen-style (symbol->style style-sym) scale))
440                  (draw-lines* dc vs sty)]))]))
441