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