image-core.rkt
1 #lang racket/base 2 3 #| 4 5 This library is the part of the 2htdp/image 6 teachpack that has to be shared between drracket 7 and the user's program to make copy and paste 8 work right. 9 10 Most of the exports are just for use in 2htdp/image 11 (technically, 2htdp/private/image-more). The main 12 use of this library is the snip class addition it 13 does (and any code that does not depend on that 14 has been moved out). 15 16 |# 17 18 (require racket/class 19 racket/list 20 racket/match 21 (except-in racket/draw 22 make-pen make-color) 23 (for-syntax racket/base) 24 file/convertible 25 pict/convert 26 (prefix-in pict: (only-in pict dc)) 27 racket/math 28 racket/contract 29 "private/image-core-bitmap.rkt" 30 "private/image-core-snipclass.rkt" 31 "private/regmk.rkt" 32 racket/snip 33 (prefix-in : racket/base) 34 (prefix-in cis: "cache-image-snip.rkt")) 35 36 37 38 39 ; 40 ; 41 ; 42 ; 43 ; 44 ; 45 ; ;; ;; ;; ;;; 46 ; ;; ;;; ;; ;;; 47 ; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;;; ;; ;;; 48 ; ;;;;;; ;; ;; ;;;; ;; ;; ;;;;;; ;; ;; ;;;; ;;;;;; 49 ; ;;; ;; ;;;; ;;; ;;;; ;;; ;; ;;;;;;;; ;; ;; ;; 50 ; ;;; ;; ;;; ;; ;;; ;;; ;; ;;; ;; ;;; ;; ;; ;; 51 ; ;;;;;; ;;; ;; ;;;;;;; ;; ;;;;;; ;;; ;; ;; ;; ;; 52 ; ;;;;; ;;;;;; ;;; ;;;;;; ;;;;; ;;;; ;; ;; ;; 53 ; 54 ; 55 ; 56 ; 57 58 59 ;; a image is 60 ;; (make-image shape bb boolean (or/c point #f)) 61 ;; NOTE: the shape field is mutated when normalized, as 62 ;; is the normalized? field. 63 (define (make-image shape bb normalized? [pinhole #f]) 64 (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole])) 65 (define (image-shape p) (send p get-shape)) 66 (define (image-bb p) (send p get-bb)) 67 (define (image-normalized? p) (send p get-normalized?)) 68 (define (set-image-shape! p s) (send p set-shape s)) 69 (define (set-image-normalized?! p n?) (send p set-normalized? n?)) 70 (define (image? p) 71 (or (is-a? p image<%>) 72 (is-a? p image-snip%) 73 (is-a? p bitmap%))) 74 75 (define (un/cache-image img bitmap-cache?) 76 (unless (image? img) 77 (raise-argument-error 'un/cache-image 78 "image?" 79 0 80 img bitmap-cache?)) 81 (cond 82 [(is-a? img snip%) 83 (define res (send img copy)) 84 (when (is-a? res image%) 85 (send res set-use-bitmap-cache?! (and bitmap-cache? #t))) 86 res] 87 [else img])) 88 89 (define (compute-image-cache img) 90 (unless (image? img) 91 (error 'compute-cached-bitmap "expected an image as the first argument, got ~e" img)) 92 (when (is-a? img image<%>) 93 (send img compute-cached-bitmap #:create-new-bitmap-if-not-ok? #t)) 94 (void)) 95 96 ;; a shape is either: 97 ;; 98 ;; - (make-overlay shape shape) 99 ;; the shapes are in the order passed to the overlay or beside, 100 ;; which means the bottom one should be drawn first so as to appear 101 ;; underneath the top one. 102 (define-struct/reg-mk overlay (top bottom) #:transparent #:omit-define-syntaxes) 103 ;; 104 ;; - (make-translate dx dy shape) 105 (define-struct/reg-mk translate (dx dy shape) #:transparent #:omit-define-syntaxes) 106 ;; 107 ;; - (make-scale x-factor y-factor shape) 108 (define-struct/reg-mk scale (x y shape) #:transparent #:omit-define-syntaxes) 109 ;; 110 ;; - (make-crop (listof vector) shape) 111 (define-struct/reg-mk crop (points shape) #:transparent #:omit-define-syntaxes) 112 ;; 113 ;; - atomic-shape 114 115 ;; an atomic-shape is either: 116 ;; - polygon 117 ;; - line-segment 118 ;; - curve-segment 119 ;; - bitmap 120 ;; - np-atomic-shape 121 122 ;; a np-atomic-shape is: 123 ;; 124 ;; - (make-ellipse width height angle mode color) 125 (define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes) 126 ;; 127 ;; - (make-text string angle number color 128 ;; number (or/c #f string) family 129 ;; (or/c 'normal 'italic) (or/c 'normal 'light 'bold) boolean) 130 ;; NOTE: font can't be the raw mred font or else copy & paste won't work 131 (define-struct/reg-mk text (string angle y-scale color size face family style weight underline) 132 #:omit-define-syntaxes #:transparent) 133 ;; 134 ;; - flip 135 136 ;; a bitmap is: 137 ;; - (make-ibitmap (and/c (is-a?/c bitmap%) (lambda (x) (send x has-alpha-channel?))) 138 ;; angle positive-real 139 ;; hash[(list boolean[flip] number[x-scale] number[y-scale] number[angle]) 140 ;; -o> (is-a?/c bitmap%)]) 141 ;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods 142 (define-struct/reg-mk ibitmap #:reflect-id bitmap (raw-bitmap angle x-scale y-scale cache) 143 #:omit-define-syntaxes #:transparent 144 #:property prop:custom-write (λ (x y z) (bitmap-write x y z))) 145 146 ;; a flip is: 147 ;; - (make-flip boolean bitmap) 148 ;; * the boolean is #t if the bitmap should be flipped vertically 149 ;; (after applying whatever rotation is in there) 150 ;; * this struct is here to avoid adding a field to bitmaps, so that old save files 151 ;; from when the library did not support flipping still load 152 ;; (since normalization will add a flip structure if necessary) 153 (define-struct/reg-mk flip (flipped? shape) #:transparent) 154 155 ;; a polygon is: 156 ;; 157 ;; - (make-polygon (listof vector) mode color) 158 (define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes) 159 160 ;; a line-segment is 161 ;; 162 ;; - (make-line-segment point point color) 163 (define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes) 164 165 ;; a curve-segment is 166 ;; 167 ;; - (make-curve-segment point real real point real real color) 168 (define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull mode color) 169 #:transparent #:omit-define-syntaxes) 170 171 ;; a normalized-shape (subtype of shape) is either 172 ;; - (make-overlay normalized-shape cn-or-simple-shape) 173 ;; - cn-or-simple-shape 174 175 ;; an cn-or-simple-shape is either: 176 ;; - simple-shape 177 ;; - (make-crop (listof points) normalized-shape) 178 179 ;; a simple-shape (subtype of shape) is 180 ;; - (make-translate dx dy np-atomic-shape) 181 ;; - polygon 182 ;; - line-segment 183 ;; - curve-segment 184 185 ;; an angle is a number between 0 and 360 (degrees) 186 187 ;; a mode is either 'solid or 'outline (indicating a pen width for outline mode) 188 189 ;; a pen is 190 ;; - (make-pen color? ;; <- the struct, not a string 191 ;; (<=/c 0 255) 192 ;; (or/c 'solid 'dot 'long-dash 'short-dash 'dot-dash) 193 ;; (or/c 'round 'projecting 'butt) 194 ;; (or/c 'round 'bevel 'miter)) 195 (define-struct/reg-mk pen (color width style cap join) #:transparent) 196 197 ;; an color is 198 ;; - (make-color (<=/c 0 255) (<=/c 0 255) (<=/c 0 255)) 199 ;; - string 200 (define-struct/reg-mk color (red green blue alpha) #:transparent) 201 (define -make-color 202 ;; this let is here just for the name 203 (let ([make-color 204 (λ (r g b [a 255]) 205 (make-color r g b a))]) 206 make-color)) 207 208 209 ;; a pulled-point is 210 ;; - (make-pulled-point real real real real real real) 211 (define-struct/reg-mk pulled-point (lpull langle x y rpull rangle) #:transparent) 212 (define (build-pulled-point lpull langle x y rpull rangle) 213 (make-pulled-point lpull 214 (if (zero? lpull) 0 langle) 215 x y 216 rpull 217 (if (zero? rpull) 0 rangle))) 218 ; 219 ; 220 ; 221 ; ;; ;; ;; 222 ; ;; ;;;; ; 223 ; ; ; ;; ; 224 ; ;; ;;;;;;;;; ;;;;; ;;;;;; ;;;; ; ;; ; 225 ; ;; ;; ;;; ;;;; ;; ;; ;; ;;; ;; ;; ; 226 ; ;; ;; ;;; ;;; ;;;; ;;; ;; ;;;;;; ; ;;; 227 ; ;; ;; ;;; ;;;;; ;; ;;; ;; ;;; ;; 228 ; ;; ;; ;;; ;;;;; ;; ;;;;; ;;; ; ; ;; ;; 229 ; ;; ;; ;;; ;;;;;;;;;; ;;;;;; ;;;; ;; ;;; 230 ; ;; ;; 231 ; ;; ; 232 ; ;;;; 233 234 (define skip-image-equality-fast-path (make-parameter #f)) 235 (define render-normalized (make-parameter #f)) 236 237 (define convertible<%> 238 (interface* () 239 ([prop:convertible 240 (lambda (img format default) 241 (case format 242 [(png-bytes) 243 (let ([s (open-output-bytes)]) 244 (send (to-bitmap (to-img img)) save-file s 'png) 245 (get-output-bytes s))] 246 [(svg-bytes) (to-svg-bytes img)] 247 [else (convert (convert-to-pict img) format default)]))] 248 [prop:pict-convertible 249 (λ (image) 250 (convert-to-pict image))]))) 251 252 (define (convert-to-pict image) 253 (define the-bb (send image get-bb)) 254 (pict:dc 255 (λ (dc dx dy) 256 (render-image image dc dx dy)) 257 (ceiling (inexact->exact (bb-right the-bb))) 258 (ceiling (inexact->exact (bb-bottom the-bb))) 259 0 260 (ceiling (inexact->exact (- (bb-bottom the-bb) 261 (bb-baseline the-bb)))))) 262 263 (define (to-bitmap img) 264 (define-values (w h) (get-size/but-subject-to-max (send img get-bb))) 265 (define bm (make-bitmap (max 1 w) (max 1 h))) 266 (define bdc (new bitmap-dc% [bitmap bm])) 267 (render-image img bdc 0 0) 268 (send bdc set-bitmap #f) 269 bm) 270 271 (define (to-svg-bytes img) 272 (define bb (send img get-bb)) 273 (define w (inexact->exact (ceiling (bb-right bb)))) 274 (define h (inexact->exact (ceiling (bb-bottom bb)))) 275 (define s (open-output-bytes)) 276 (define svg-dc (new svg-dc% [width w] [height h] [output s])) 277 (send svg-dc start-doc "") 278 (send svg-dc start-page) 279 (render-image img svg-dc 0 0) 280 (send svg-dc end-page) 281 (send svg-dc end-doc) 282 (get-output-bytes s)) 283 284 (define max-size (* 5000 5000)) 285 (define (get-size/but-subject-to-max bb) 286 (define w (inexact->exact (ceiling (bb-right bb)))) 287 (define h (inexact->exact (ceiling (bb-bottom bb)))) 288 (get-size/but-subject-to-max/wh w h)) 289 290 (define (get-size/but-subject-to-max/wh w h) 291 (cond 292 [(<= (* w h) max-size) (values w h)] 293 [(< w h) (values w (ceiling (/ max-size w)))] 294 [else (values (ceiling (/ max-size h)) h)])) 295 296 (module+ test 297 (require rackunit) 298 (check-equal? (call-with-values 299 (λ () (get-size/but-subject-to-max/wh 10 10)) 300 list) 301 '(10 10)) 302 (check-equal? (call-with-values 303 (λ () (get-size/but-subject-to-max/wh 5000 10000)) 304 list) 305 '(5000 5000)) 306 (check-equal? (call-with-values 307 (λ () (get-size/but-subject-to-max/wh 10000 5000)) 308 list) 309 '(5000 5000)) 310 (check-equal? (call-with-values 311 (λ () (get-size/but-subject-to-max/wh 5001 5000)) 312 list) 313 '(5000 5000)) 314 (check-equal? (call-with-values 315 (λ () (get-size/but-subject-to-max/wh 6000 6001)) 316 list) 317 '(6000 4167))) 318 319 (define-local-member-name 320 set-use-bitmap-cache?! 321 set-cached-bitmap 322 compute-cached-bitmap) 323 324 (define image% 325 (class* snip% (convertible<%> image<%>) 326 (init-field shape bb normalized? pinhole) 327 328 (define/override (equal-to? that eq-recur) (compare-em that eq-recur)) 329 (define/override (other-equal-to? that eq-recur) (compare-em that eq-recur)) 330 331 (define/private (compare-em that eq-recur) 332 (or (eq? this that) 333 (let ([that 334 (cond 335 [(is-a? that image-snip%) (image-snip->image that)] 336 [(is-a? that bitmap%) (bitmap->image that)] 337 [else that])]) 338 (and (is-a? that image%) 339 (same-width/height? bb (send that get-bb)) 340 (equal? pinhole (send that get-pinhole)) 341 (or (and (not (skip-image-equality-fast-path)) ;; this makes testing more effective 342 (equal? (get-normalized-shape) (send that get-normalized-shape))) 343 344 ;; some shapes (ie, outline rectangles with a 1 pixel edge) draw 1 outside 345 ;; the bounding box so we make the bitmap slightly bigger to accommodate that. 346 (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] 347 [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) 348 (or ;(zero? w) 349 ;(zero? h) 350 (let ([bm1 (make-bitmap w h #t)] 351 [bm2 (make-bitmap w h #t)] 352 [bytes1 (make-bytes (* w h 4) 0)] 353 [bytes2 (make-bytes (* w h 4) 0)] 354 [bdc (make-object bitmap-dc%)]) 355 (draw-into bm1 bdc bytes1 this) 356 (draw-into bm2 bdc bytes2 that) 357 (equal? bytes1 bytes2))))))))) 358 359 (define/private (draw-into bm bdc bytes obj) 360 (send bdc set-bitmap bm) 361 (send bdc erase) 362 (render-image obj bdc 0 0) 363 (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes #f #t)) 364 365 ;; this could render the image into a bitmap and then get the hash code of the bytes 366 ;; cannot render the tree into a string and then get the hash code of that string 367 ;; b/c that might make equal things have the same code. 368 (define/override (equal-hash-code-of y) 42) 369 (define/override (equal-secondary-hash-code-of y) 3) 370 371 (define/public (get-shape) shape) 372 (define/public (set-shape s) (set! shape s)) 373 (define/public (get-bb) bb) 374 (define/public (get-pinhole) pinhole) 375 (define/public (get-normalized?) normalized?) 376 (define/public (set-normalized? n?) (set! normalized? n?)) 377 378 (define/public (get-normalized-shape) 379 (unless normalized? 380 (set! shape (normalize-shape shape)) 381 (set! normalized? #t)) 382 shape) 383 384 (inherit get-admin) 385 (define scroll-step #f) 386 (define/private (calc-scroll-step) 387 (unless scroll-step 388 ;; try to set scroll step by font size of the standard style 389 (let ([admin (get-admin)]) 390 (when admin 391 (let* ([ed (send admin get-editor)] 392 [sl (send ed get-style-list)] 393 [standard (send sl find-named-style "Standard")]) 394 (when standard 395 (let ([dc (make-object bitmap-dc% (make-object bitmap% 1 1))]) 396 (let-values ([(w h d a) (send dc get-text-extent "X" (send standard get-font))]) 397 (set! scroll-step (+ h (send admin get-line-spacing))))))))) 398 ;; if that didn't happen, set it to 12. 399 (unless scroll-step (set! scroll-step 12)))) 400 401 (define/override (get-num-scroll-steps) 402 (calc-scroll-step) 403 (inexact->exact (ceiling (/ (bb-bottom bb) scroll-step)))) 404 (define/override (get-scroll-step-offset offset) 405 (calc-scroll-step) 406 (min (inexact->exact (ceiling (* offset scroll-step))) 407 (bb-bottom bb))) 408 (define/override (find-scroll-step y) 409 (calc-scroll-step) 410 (inexact->exact (ceiling (/ y scroll-step)))) 411 412 (define/override (copy) 413 (define res (make-image shape bb normalized? pinhole)) 414 (when cached-bitmap 415 (send res set-cached-bitmap cached-bitmap)) 416 res) 417 418 (define cached-bitmap #f) 419 (define use-cached-bitmap? #t) 420 421 ;; this method is only used by the 'copy' method 422 (define/public (set-cached-bitmap bm) (set! cached-bitmap bm)) 423 424 (define/public (compute-cached-bitmap #:create-new-bitmap-if-not-ok? 425 [create-new-bitmap-if-not-ok? #f]) 426 (when use-cached-bitmap? 427 (when (or (not cached-bitmap) 428 (and create-new-bitmap-if-not-ok? 429 (not (send cached-bitmap ok?)))) 430 (define-values (w h) (get-size/but-subject-to-max bb)) 431 (set! cached-bitmap (make-bitmap (+ w 1) (+ h 1))) 432 (when (send cached-bitmap ok?) 433 (define bdc (make-object bitmap-dc% cached-bitmap)) 434 (send bdc erase) 435 (render-image this bdc 0 0) 436 (send bdc set-bitmap #f))))) 437 438 (define/public (set-use-bitmap-cache?! u-b-c?) 439 (set! use-cached-bitmap? u-b-c?) 440 (unless use-cached-bitmap? 441 (set! cached-bitmap #f))) 442 443 (define/override (draw dc x y left top right bottom dx dy draw-caret) 444 (compute-cached-bitmap) 445 446 ;; if the cached bitmap is not ok? that means we probably 447 ;; ran out of memory trying to allocate it. In that case, 448 ;; instead of failing, we just draw nothing. Don't try 449 ;; to fall back to the other drawing method because 450 ;; of the invariant that if a bitmap is present, we must 451 ;; use it or drawing nothing to avoid calling into unknown 452 ;; code in certain contexts 453 (let ([alpha (send dc get-alpha)]) 454 (when (pair? draw-caret) 455 (send dc set-alpha (* alpha .5))) 456 (if use-cached-bitmap? 457 (when (send cached-bitmap ok?) 458 (send dc draw-bitmap cached-bitmap x y)) 459 (render-image this dc x y)) 460 (send dc set-alpha alpha))) 461 462 (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) 463 (send (get-the-snip-class-list) add snip-class) 464 (let ([bottom (round (bb-bottom bb))] 465 [right (round (bb-right bb))]) 466 (set-box/f! w right) 467 (set-box/f! h bottom) 468 (set-box/f! descent (- bottom (round (bb-baseline bb)))) 469 (set-box/f! space 0) 470 (set-box/f! lspace 0) 471 (set-box/f! rspace 0))) 472 473 (define/override (write f) 474 (define bytes (image->snipclass-bytes this)) 475 (send f put (bytes-length bytes) bytes)) 476 477 (super-new) 478 479 (inherit set-snipclass) 480 (set-snipclass snip-class))) 481 482 (define (definitely-same-image? i1 i2) 483 (cond 484 [(and (is-a? i1 image<%>) (is-a? i2 image<%>)) 485 (equal? (send i1 get-normalized-shape) 486 (send i2 get-normalized-shape))] 487 [(or (is-a? i1 image<%>) (is-a? i2 image<%>)) 488 #f] 489 [else 490 (define bm1 (if (is-a? i1 image-snip%) 491 (send i1 get-bitmap) 492 i2)) 493 (define bm2 (if (is-a? i2 image-snip%) 494 (send i2 get-bitmap) 495 i2)) 496 (eq? bm1 bm2)])) 497 498 (define (same-bb? bb1 bb2) 499 (and (same-width/height? bb1 bb2) 500 (= (round (bb-baseline bb1)) (round (bb-baseline bb2))))) 501 502 (define (same-width/height? bb1 bb2) 503 (and (= (round (bb-right bb1)) (round (bb-right bb2))) 504 (= (round (bb-bottom bb1)) (round (bb-bottom bb2))))) 505 506 (define racket/base:read read) 507 (define image-snipclass% 508 (class snip-class% 509 (define/override (read f) (snipclass-bytes->image (send f get-unterminated-bytes))) 510 (super-new))) 511 512 (define (snipclass-bytes->image bytes) 513 (define lst (parse (fetch bytes))) 514 (cond 515 [(not lst) 516 (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black")) 517 (make-bb 100 100 100) 518 #f 519 #f)] 520 [else 521 (make-image (list-ref lst 0) 522 (list-ref lst 1) 523 #f 524 (list-ref lst 2))])) 525 526 (define (image->snipclass-bytes img) 527 (define bp (open-output-bytes)) 528 (parameterize ([print-graph #t] 529 [bitmap-write-cache (make-hasheq)]) 530 (:write (list (send img get-shape) 531 (send img get-bb) 532 (send img get-pinhole)) 533 bp)) 534 (get-output-bytes bp)) 535 536 (provide snip-class) 537 (define snip-class (new image-snipclass%)) 538 (send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib") 539 '(lib "image-core-wxme.rkt" "mrlib")))) 540 (send snip-class set-version 1) 541 (send (get-the-snip-class-list) add snip-class) 542 543 (define (set-box/f! b v) (when (box? b) (set-box! b v))) 544 545 (define (parse sexp) 546 (let/ec k 547 (let loop ([sexp sexp]) 548 (cond 549 [(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))] 550 [(and (immutable? sexp) (hash? sexp)) 551 (hash-copy sexp)] 552 [(vector? sexp) 553 (if (= (vector-length sexp) 0) 554 (k #f) 555 (cond 556 [(bytes? (vector-ref sexp 0)) 557 ;; bitmaps are vectors with a bytes in the first field 558 ;; in older versions, there were three elements of the vector 559 ;; and the bytes in the first element were the raw bytes (from get-argb-pixels) 560 ;; in the current version, the bytes are png bytes and there are two elements 561 ;; in the vector; the second is the backing scale 562 (if (= (vector-length sexp) 3) 563 (apply bytes->bitmap (vector->list sexp)) 564 (apply png-bytes->bitmap (vector->list sexp)))] 565 [else 566 (let* ([tag (vector-ref sexp 0)] 567 [args (cdr (vector->list sexp))] 568 [constructor (id->constructor tag)] 569 [arg-count (length args)] 570 [parsed-args (map loop args)]) 571 (cond 572 [(and constructor 573 (procedure-arity-includes? constructor arg-count) 574 (equal? tag 'struct:polygon)) 575 (define points (list-ref parsed-args 0)) 576 ;; in older versions, polygons had points as the 577 ;; first argument, but now they have pulled-points 578 (define adjusted-points 579 (for/list ([p (in-list points)]) 580 (cond 581 [(point? p) 582 (make-pulled-point 0 0 583 (point-x p) 584 (point-y p) 585 0 0)] 586 [else p]))) 587 (apply constructor adjusted-points (cdr parsed-args))] 588 [(and constructor (procedure-arity-includes? constructor arg-count)) 589 (apply constructor parsed-args)] 590 [(and (eq? tag 'struct:bitmap) 591 (= arg-count 7)) 592 ;; we changed the arity of the bitmap constructor from old versions, 593 ;; so fix it up here. 594 (make-ibitmap (list-ref parsed-args 0) 595 (list-ref parsed-args 2) 596 (list-ref parsed-args 3) 597 (list-ref parsed-args 4) 598 (make-hash))] 599 [(and (eq? tag 'struct:bitmap) 600 (= arg-count 6)) 601 ;; we changed the arity of the bitmap constructor from old versions, 602 ;; so fix it up here. it used to have these fields: 603 ;; (raw-bitmap raw-mask angle x-scale y-scale cache) 604 ;; and the mask field was dropped in favor of always having an alpha bitmap in 605 ;; the raw-bitmap field. The bytes that were written out always had the mask 606 ;; factored in, tho (which led to a bug) so we can just ignore the mask here 607 (make-ibitmap (list-ref parsed-args 0) 608 (list-ref parsed-args 2) 609 (list-ref parsed-args 3) 610 (list-ref parsed-args 4) 611 (make-hash))] 612 [(and (eq? tag 'struct:color) 613 (= arg-count 3)) 614 ;; we changed the arity of the color constructor from old versions, 615 ;; so fix it up here. 616 (make-color (list-ref parsed-args 0) 617 (list-ref parsed-args 1) 618 (list-ref parsed-args 2) 619 255)] 620 [(and (eq? tag 'struct:curve-segment) 621 (= arg-count 7)) 622 ;; new version (start s-angle s-pull end e-angle e-pull mode color) 623 ;; old version (start s-angle s-pull end e-angle e-pull color) 624 ;; with mode defaulting to 'outline 625 (make-curve-segment (list-ref parsed-args 0) 626 (list-ref parsed-args 1) 627 (list-ref parsed-args 2) 628 (list-ref parsed-args 3) 629 (list-ref parsed-args 4) 630 (list-ref parsed-args 5) 631 'outline 632 (list-ref parsed-args 6))] 633 [else 634 (k #f)]))]))] 635 [else sexp])))) 636 637 (define (normalized-shape? s) 638 (cond 639 [(overlay? s) 640 (and (normalized-shape? (overlay-top s)) 641 (cn-or-simple-shape? (overlay-bottom s)))] 642 [else 643 (cn-or-simple-shape? s)])) 644 645 (define (cn-or-simple-shape? s) 646 (cond 647 [(crop? s) 648 (normalized-shape? (crop-shape s))] 649 [else 650 (simple-shape? s)])) 651 652 (define (simple-shape? shape) 653 (or (and (translate? shape) 654 (np-atomic-shape? (translate-shape shape))) 655 (polygon? shape) 656 (line-segment? shape) 657 (curve-segment? shape))) 658 659 (define (atomic-shape? shape) 660 (or (polygon? shape) 661 (line-segment? shape) 662 (curve-segment? shape) 663 (ibitmap? shape) 664 (np-atomic-shape? shape))) 665 666 (define (np-atomic-shape? shape) 667 (or (ellipse? shape) 668 (text? shape) 669 (and (flip? shape) 670 (boolean? (flip-flipped? shape)) 671 (ibitmap? (flip-shape shape))))) 672 673 ;; normalize-shape : shape -> normalized-shape 674 ;; normalizes 'shape', calling 'f' on each atomic shape in the normalized shape. 675 (define/contract (normalize-shape shape) 676 (-> any/c ;; should be shape? 677 normalized-shape?) 678 (let loop ([shape shape] 679 [dx 0] 680 [dy 0] 681 [x-scale 1] 682 [y-scale 1] 683 [bottom #f]) 684 (define (scale-point p) 685 (make-point (+ dx (* x-scale (point-x p))) 686 (+ dy (* y-scale (point-y p))))) 687 (define (scale-pulled-point p) 688 (make-pulled-point (pulled-point-lpull p) 689 (pulled-point-langle p) 690 (+ dx (* x-scale (pulled-point-x p))) 691 (+ dy (* y-scale (pulled-point-y p))) 692 (pulled-point-rpull p) 693 (pulled-point-rangle p))) 694 (cond 695 [(translate? shape) 696 (loop (translate-shape shape) 697 (+ dx (* x-scale (translate-dx shape))) 698 (+ dy (* y-scale (translate-dy shape))) 699 x-scale 700 y-scale 701 bottom)] 702 [(scale? shape) 703 (loop (scale-shape shape) 704 dx 705 dy 706 (* x-scale (scale-x shape)) 707 (* y-scale (scale-y shape)) 708 bottom)] 709 [(overlay? shape) 710 (loop (overlay-bottom shape) 711 dx dy x-scale y-scale 712 (loop (overlay-top shape) 713 dx dy x-scale y-scale 714 bottom))] 715 [(crop? shape) 716 (let* ([inside (loop (crop-shape shape) 717 dx dy x-scale y-scale 718 #f)] 719 [this-one 720 (make-crop (map scale-point (crop-points shape)) 721 inside)]) 722 (if bottom 723 (make-overlay bottom this-one) 724 this-one))] 725 [(polygon? shape) 726 (define this-one 727 (make-polygon (map scale-pulled-point (polygon-points shape)) 728 (polygon-mode shape) 729 (scale-color (polygon-color shape) x-scale y-scale))) 730 (if bottom 731 (make-overlay bottom this-one) 732 this-one)] 733 [(line-segment? shape) 734 (let ([this-one 735 (make-line-segment (scale-point (line-segment-start shape)) 736 (scale-point (line-segment-end shape)) 737 (scale-color (line-segment-color shape) x-scale y-scale))]) 738 (if bottom 739 (make-overlay bottom this-one) 740 this-one))] 741 [(curve-segment? shape) 742 ;; the pull is multiplied by the distance 743 ;; between the two points when it is drawn, 744 ;; so we don't need to scale it here 745 (let ([this-one 746 (make-curve-segment (scale-point (curve-segment-start shape)) 747 (curve-segment-s-angle shape) 748 (curve-segment-s-pull shape) 749 (scale-point (curve-segment-end shape)) 750 (curve-segment-e-angle shape) 751 (curve-segment-e-pull shape) 752 (curve-segment-mode shape) 753 (scale-color (curve-segment-color shape) x-scale y-scale))]) 754 (if bottom 755 (make-overlay bottom this-one) 756 this-one))] 757 [(or (ibitmap? shape) (np-atomic-shape? shape)) 758 (let ([shape (if (ibitmap? shape) 759 (make-flip #f shape) 760 shape)]) 761 (let ([this-one 762 (make-translate dx dy (scale-np-atomic x-scale y-scale shape))]) 763 (if bottom 764 (make-overlay bottom this-one) 765 this-one)))] 766 [else 767 (error 'normalize-shape "unknown shape ~s\n" shape)]))) 768 769 (define/contract (scale-np-atomic x-scale y-scale shape) 770 (-> number? number? np-atomic-shape? np-atomic-shape?) 771 (cond 772 [(ellipse? shape) 773 (make-ellipse (* x-scale (ellipse-width shape)) 774 (* y-scale (ellipse-height shape)) 775 (ellipse-angle shape) 776 (ellipse-mode shape) 777 (scale-color (ellipse-color shape) x-scale y-scale))] 778 [(text? shape) 779 ;; should probably do something different here so that 780 ;; the y-scale is always greater than 1 781 ;; (or else always smaller than 1) 782 (make-text (text-string shape) 783 (text-angle shape) 784 (* (text-y-scale shape) (/ y-scale x-scale)) 785 (text-color shape) 786 (* (text-size shape) x-scale) 787 (text-face shape) 788 (text-family shape) 789 (text-style shape) 790 (text-weight shape) 791 (text-underline shape))] 792 [(flip? shape) 793 (cond 794 [(and (= 1 x-scale) (= 1 y-scale)) 795 shape] 796 [else 797 (let ([bitmap (flip-shape shape)]) 798 (make-flip (flip-flipped? shape) 799 (make-ibitmap (ibitmap-raw-bitmap bitmap) 800 (ibitmap-angle bitmap) 801 (* x-scale (ibitmap-x-scale bitmap)) 802 (* y-scale (ibitmap-y-scale bitmap)) 803 (ibitmap-cache bitmap))))])])) 804 805 (define (scale-color color x-scale y-scale) 806 (cond 807 [(pen? color) 808 (make-pen (pen-color color) 809 (* (pen-width color) (/ (+ x-scale y-scale) 2)) 810 (pen-style color) 811 (pen-cap color) 812 (pen-join color))] 813 [else color])) 814 815 ; 816 ; 817 ; 818 ; 819 ; 820 ; 821 ; ;; ;; 822 ; ;; ;; 823 ; ;;;; ;;;; ;; ;;; ;;;;; ;;;; ;;;;;;; ;; ;;; ;;;;;; 824 ; ;;;; ;; ;; ;;;;;; ;;;;;; ;; ;; ;;;; ;; ;;;;;; ;;;;;; 825 ; ;; ;;;;;;;; ;; ;; ;;; ;; ;;;;;;;; ;; ;; ;; ;; ;;; ;; 826 ; ;; ;;; ;; ;; ;;; ;; ;;; ;; ;; ;; ;; ;;; ;; 827 ; ;; ;;; ;; ;; ;; ;;;;;; ;;; ;; ;; ;; ;; ;; ;;;;;; 828 ; ;; ;;;; ;; ;; ;;;;; ;;;; ;; ;; ;; ;; ;;;;; 829 ; ;; ;;; 830 ; ;;;;; 831 ; 832 ; 833 834 ;; render-image : image dc dx dy -> void 835 (define (render-image image dc dx dy) 836 (let ([pen (send dc get-pen)] 837 [brush (send dc get-brush)] 838 [font (send dc get-font)] 839 [fg (send dc get-text-foreground)] 840 [smoothing (send dc get-smoothing)] 841 [alpha (send dc get-alpha)]) 842 (cond 843 [(is-a? image bitmap%) 844 (send dc draw-bitmap image dx dy)] 845 [(is-a? image image-snip%) 846 (send dc draw-bitmap (send image get-bitmap) dx dy)] 847 [else 848 (if (render-normalized) 849 (render-normalized-shape (send image get-normalized-shape) dc dx dy) 850 (render-arbitrary-shape (send image get-shape) dc dx dy)) 851 (let ([ph (send image get-pinhole)]) 852 (when ph 853 (let* ([px (point-x ph)] 854 [py (point-y ph)] 855 [bb (image-bb image)] 856 [w (bb-right bb)] 857 [h (bb-bottom bb)]) 858 (send dc set-alpha (* alpha .5)) 859 (send dc set-smoothing 'smoothed) 860 861 (send dc set-pen "white" 1 'solid) 862 (send dc draw-line (+ dx px .5) (+ dy .5) (+ dx px .5) (+ dy h -.5)) 863 (send dc draw-line (+ dx .5) (+ dy py .5) (+ dx w -.5) (+ dy py .5)) 864 865 (send dc set-pen "black" 1 'solid) 866 (send dc draw-line (+ dx px -.5) (+ dy .5) (+ dx px -.5) (+ dy h -.5)) 867 (send dc draw-line (+ dx .5) (+ dy py -.5) (+ dx w -.5) (+ dy py -.5)))))]) 868 (send dc set-pen pen) 869 (send dc set-brush brush) 870 (send dc set-font font) 871 (send dc set-text-foreground fg) 872 (send dc set-smoothing smoothing) 873 (send dc set-alpha alpha))) 874 875 (define (save-image-as-bitmap image filename kind) 876 (let* ([bb (send image get-bb)] 877 [bm (make-bitmap 878 (+ 1 (ceiling (inexact->exact (bb-right bb)))) 879 (+ 1 (ceiling (inexact->exact (bb-bottom bb)))))] 880 [bdc (make-object bitmap-dc% bm)]) 881 (render-image image bdc 0 0) 882 (send bdc set-bitmap #f) 883 (send bm save-file filename kind))) 884 885 (define (render-normalized-shape shape dc dx dy) 886 (cond 887 [(overlay? shape) 888 (render-cn-or-simple-shape (overlay-bottom shape) dc dx dy) 889 (render-normalized-shape (overlay-top shape) dc dx dy)] 890 [else 891 (render-cn-or-simple-shape shape dc dx dy)])) 892 893 (define last-cropped-points (make-parameter #f)) 894 895 (define (render-cn-or-simple-shape shape dc dx dy) 896 (cond 897 [(crop? shape) 898 (render-cropped-shape (crop-points shape) 899 (crop-shape shape) 900 (λ (s) (render-normalized-shape s dc dx dy)) 901 dc dx dy)] 902 [else 903 (render-simple-shape shape dc dx dy)])) 904 905 (define (render-cropped-shape points inner-shape continue dc dx dy) 906 (cond 907 [(equal? points (last-cropped-points)) 908 (continue inner-shape)] 909 [else 910 (let ([old-region (send dc get-clipping-region)] 911 [new-region (new region% [dc dc])] 912 [path (polygon-points->path points)]) 913 (send new-region set-path path dx dy) 914 (when old-region (send new-region intersect old-region)) 915 (send dc set-clipping-region new-region) 916 (parameterize ([last-cropped-points points]) 917 (continue inner-shape)) 918 (send dc set-clipping-region old-region))])) 919 920 (define (render-simple-shape simple-shape dc dx dy) 921 (cond 922 [(translate? simple-shape) 923 (let ([dx (+ dx (translate-dx simple-shape))] 924 [dy (+ dy (translate-dy simple-shape))] 925 [np-atomic-shape (translate-shape simple-shape)]) 926 (render-np-atomic-shape np-atomic-shape 927 dc 928 dx dy))] 929 [else 930 (render-poly/line-segment/curve-segment simple-shape dc dx dy)])) 931 932 (define (render-arbitrary-shape shape dc dx dy) 933 (let loop ([shape shape] 934 [dx dx] 935 [dy dy] 936 [x-scale 1] 937 [y-scale 1]) 938 (define (scale-point p) 939 (make-point (* x-scale (point-x p)) 940 (* y-scale (point-y p)))) 941 (define (scale-pulled-point p) 942 (make-pulled-point (pulled-point-lpull p) 943 (pulled-point-langle p) 944 (* x-scale (pulled-point-x p)) 945 (* y-scale (pulled-point-y p)) 946 (pulled-point-rpull p) 947 (pulled-point-rangle p))) 948 (cond 949 [(translate? shape) 950 (loop (translate-shape shape) 951 (+ dx (* x-scale (translate-dx shape))) 952 (+ dy (* y-scale (translate-dy shape))) 953 x-scale 954 y-scale)] 955 [(scale? shape) 956 (loop (scale-shape shape) 957 dx 958 dy 959 (* x-scale (scale-x shape)) 960 (* y-scale (scale-y shape)))] 961 [(overlay? shape) 962 (loop (overlay-bottom shape) dx dy x-scale y-scale) 963 (loop (overlay-top shape) dx dy x-scale y-scale)] 964 [(crop? shape) 965 (render-cropped-shape 966 (map scale-point (crop-points shape)) 967 (crop-shape shape) 968 (λ (s) (loop s dx dy x-scale y-scale)) dc dx dy)] 969 [(polygon? shape) 970 (define this-one 971 (make-polygon (map scale-pulled-point (polygon-points shape)) 972 (polygon-mode shape) 973 (scale-color (polygon-color shape) x-scale y-scale))) 974 (render-poly/line-segment/curve-segment this-one dc dx dy)] 975 [(line-segment? shape) 976 (let ([this-one 977 (make-line-segment (scale-point (line-segment-start shape)) 978 (scale-point (line-segment-end shape)) 979 (scale-color (line-segment-color shape) x-scale y-scale))]) 980 (render-poly/line-segment/curve-segment this-one dc dx dy))] 981 [(curve-segment? shape) 982 ;; the pull is multiplied by the distance 983 ;; between the two points when it is drawn, 984 ;; so we don't need to scale it here 985 (define this-one 986 (make-curve-segment (scale-point (curve-segment-start shape)) 987 (curve-segment-s-angle shape) 988 (curve-segment-s-pull shape) 989 (scale-point (curve-segment-end shape)) 990 (curve-segment-e-angle shape) 991 (curve-segment-e-pull shape) 992 (curve-segment-mode shape) 993 (scale-color (curve-segment-color shape) x-scale y-scale))) 994 (render-poly/line-segment/curve-segment this-one dc dx dy)] 995 [(or (ibitmap? shape) (np-atomic-shape? shape)) 996 (let* ([shape (if (ibitmap? shape) 997 (make-flip #f shape) 998 shape)] 999 [this-one (scale-np-atomic x-scale y-scale shape)]) 1000 (render-np-atomic-shape this-one dc dx dy))] 1001 [else 1002 (error 'normalize-shape "unknown shape ~s\n" shape)]))) 1003 1004 (define/contract (render-poly/line-segment/curve-segment simple-shape dc dx dy) 1005 (-> (or/c polygon? line-segment? curve-segment?) any/c any/c any/c void?) 1006 (cond 1007 [(polygon? simple-shape) 1008 (let ([mode (polygon-mode simple-shape)] 1009 [color (polygon-color simple-shape)] 1010 [path (polygon-pulled-points->path (polygon-points simple-shape))]) 1011 (send dc set-pen (mode-color->pen mode color)) 1012 (send dc set-brush (mode-color->brush mode color)) 1013 (send dc set-smoothing (mode-color->smoothing mode color)) 1014 (send dc draw-path path dx dy 'winding))] 1015 [(line-segment? simple-shape) 1016 (let* ([start (line-segment-start simple-shape)] 1017 [end (line-segment-end simple-shape)] 1018 [path (new dc-path%)] 1019 [sx (point-x start)] 1020 [sy (point-y start)] 1021 [ex (point-x end)] 1022 [ey (point-y end)]) 1023 (send path move-to sx sy) 1024 (send path line-to ex ey) 1025 (send dc set-pen (mode-color->pen 'outline (line-segment-color simple-shape))) 1026 (send dc set-brush "black" 'transparent) 1027 (send dc set-smoothing 'smoothed) 1028 (send dc draw-path path dx dy))] 1029 [(curve-segment? simple-shape) 1030 (define path (curve-segment->path simple-shape)) 1031 (send dc set-pen (mode-color->pen (curve-segment-mode simple-shape) 1032 (curve-segment-color simple-shape))) 1033 (send dc set-brush (mode-color->brush (curve-segment-mode simple-shape) 1034 (curve-segment-color simple-shape))) 1035 (send dc set-smoothing 'smoothed) 1036 (send dc draw-path path dx dy)])) 1037 1038 (define (curve-segment->path simple-shape) 1039 (define start (curve-segment-start simple-shape)) 1040 (define end (curve-segment-end simple-shape)) 1041 (define sx (point-x start)) 1042 (define sy (point-y start)) 1043 (define ex (point-x end)) 1044 (define ey (point-y end)) 1045 (define sa (degrees->radians (curve-segment-s-angle simple-shape))) 1046 (define ea (degrees->radians (curve-segment-e-angle simple-shape))) 1047 1048 (define path (new dc-path%)) 1049 (define d (sqrt (+ (sqr (- ey sy)) (sqr (- ex sx))))) 1050 (define sp (* (curve-segment-s-pull simple-shape) d)) 1051 (define ep (* (curve-segment-e-pull simple-shape) d)) 1052 (send path move-to sx sy) 1053 (send path curve-to 1054 (+ sx (* sp (cos sa))) 1055 (- sy (* sp (sin sa))) 1056 (- ex (* ep (cos ea))) 1057 (+ ey (* ep (sin ea))) 1058 ex 1059 ey) 1060 path) 1061 1062 (define (render-np-atomic-shape np-atomic-shape dc dx dy) 1063 (cond 1064 [(ellipse? np-atomic-shape) 1065 (let* ([path (new dc-path%)] 1066 [ew (ellipse-width np-atomic-shape)] 1067 [eh (ellipse-height np-atomic-shape)] 1068 [θ (degrees->radians (ellipse-angle np-atomic-shape))] 1069 [color (ellipse-color np-atomic-shape)] 1070 [mode (ellipse-mode np-atomic-shape)]) 1071 (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)]) 1072 (send path ellipse 0 0 ew eh) 1073 (send path translate (- (/ ew 2)) (- (/ eh 2))) 1074 (send path rotate θ) 1075 (send dc set-pen (mode-color->pen mode color)) 1076 (send dc set-brush (mode-color->brush mode color)) 1077 (send dc set-smoothing (mode-color->smoothing mode color)) 1078 (send dc draw-path path dx dy)))] 1079 [(flip? np-atomic-shape) 1080 (cond 1081 [(flip-flipped? np-atomic-shape) 1082 (define key (get-bitmap-cache-key np-atomic-shape)) 1083 (define bm (lookup/calc-rendered-bitmap np-atomic-shape key)) 1084 (send dc set-smoothing 'smoothed) 1085 (send dc draw-bitmap 1086 bm 1087 (- dx (/ (send bm get-width) 2)) 1088 (- dy (/ (send bm get-height) 2)))] 1089 [else 1090 (define transformation (send dc get-transformation)) 1091 (define bitmap (flip-shape np-atomic-shape)) 1092 (define bitmap-obj (ibitmap-raw-bitmap bitmap)) 1093 1094 (define θ (degrees->radians (ibitmap-angle bitmap))) 1095 1096 (send dc translate dx dy) 1097 (send dc rotate θ) 1098 1099 (define bw (send bitmap-obj get-width)) 1100 (define bh (send bitmap-obj get-height)) 1101 1102 (send dc translate 1103 (* (ibitmap-x-scale bitmap) (- (/ bw 2))) 1104 (* (ibitmap-y-scale bitmap) (- (/ bh 2)))) 1105 (send dc set-scale (ibitmap-x-scale bitmap) (ibitmap-y-scale bitmap)) 1106 1107 (send dc draw-bitmap bitmap-obj 0 0) 1108 1109 (send dc set-transformation transformation) 1110 bitmap-obj])] 1111 [(text? np-atomic-shape) 1112 (define θ (degrees->radians (text-angle np-atomic-shape))) 1113 (define font (send dc get-font)) 1114 (send dc set-font (text->font np-atomic-shape)) 1115 (send dc set-smoothing 'aligned) ;; should this be smoothed? 1116 (define color (get-color-arg (text-color np-atomic-shape))) 1117 (send dc set-text-foreground 1118 (cond 1119 [(string? color) (string->color-object color)] 1120 [else color])) 1121 (define-values (w h _1 _2) (send dc get-text-extent (text-string np-atomic-shape))) 1122 (define t-y-scale (text-y-scale np-atomic-shape)) 1123 (define-values (px py) (text-details->origin-offset dx dy t-y-scale θ w h)) 1124 (define-values (x-scale y-scale) (send dc get-scale)) 1125 (define-values (ox oy) (send dc get-origin)) 1126 (send dc set-origin (+ ox px) (+ oy py)) 1127 (send dc set-scale x-scale (* y-scale (text-y-scale np-atomic-shape))) 1128 (send dc draw-text (text-string np-atomic-shape) 0 0 #f 0 θ) 1129 (send dc set-scale x-scale y-scale) 1130 (send dc set-origin ox oy)])) 1131 1132 (define (text-details->origin-offset dx dy t-y-scale θ w h) 1133 (define p (- (make-rectangular dx dy) 1134 (* (make-polar 1 (- θ)) (make-rectangular (/ w 2) 1135 (* t-y-scale (/ h 2)))))) 1136 (values (real-part p) 1137 (imag-part p))) 1138 1139 (module+ test 1140 (check-equal? (call-with-values (λ () (text-details->origin-offset 10.0 10.0 1/2 0 20.0 40.0)) list) 1141 (list 0.0 0.0))) 1142 1143 (define (polygon-pulled-points->path pulled-points) 1144 (define path (new dc-path%)) 1145 (define first-point (car pulled-points)) 1146 (send path move-to (pulled-point-x first-point) (pulled-point-y first-point)) 1147 (let loop ([prev-point (car pulled-points)] 1148 [pulled-points (cdr pulled-points)]) 1149 (define this-point (if (null? pulled-points) 1150 first-point 1151 (car pulled-points))) 1152 (match-define (pulled-point slpull slangle sx sy srpull srangle) prev-point) 1153 (match-define (pulled-point elpull elangle ex ey erpull erangle) this-point) 1154 (define vec (- (make-rectangular ex ey) (make-rectangular sx sy))) 1155 (define sa (degrees->radians srangle)) 1156 (define ea (degrees->radians elangle)) 1157 (define p1 (* vec (make-polar srpull sa))) 1158 (define p2 (* (- vec) (make-polar elpull ea))) 1159 1160 (send path curve-to 1161 (+ sx (real-part p1)) 1162 (+ sy (imag-part p1)) 1163 (+ ex (real-part p2)) 1164 (+ ey (imag-part p2)) 1165 ex 1166 ey) 1167 (unless (null? pulled-points) 1168 (loop (car pulled-points) (cdr pulled-points)))) 1169 (send path close) 1170 path) 1171 1172 (define (polygon-points->path points) 1173 (define path (new dc-path%)) 1174 (send path move-to (point-x (car points)) (point-y (car points))) 1175 (let loop ([points (cdr points)]) 1176 (unless (null? points) 1177 (define pt (car points)) 1178 (send path line-to (point-x pt) (point-y pt)) 1179 (loop (cdr points)))) 1180 (send path close) 1181 path) 1182 1183 ;; points->ltrb-values : (cons point (listof points)) -> (values number number number number) 1184 (define (points->ltrb-values points) 1185 (unless (and (list? points) 1186 (pair? points) 1187 (andmap (or/c point? pulled-point?) points)) 1188 (raise-argument-error 'points->ltrb-values 1189 "(non-empty-listof (or/c point? pulled-point?))" 1190 0 points)) 1191 (define fx (pp->x (car points))) 1192 (define fy (pp->y (car points))) 1193 (define left fx) 1194 (define top fy) 1195 (define right fx) 1196 (define bottom fy) 1197 (for ([point (in-list (cdr points))]) 1198 (define new-x (pp->x point)) 1199 (define new-y (pp->y point)) 1200 (set! left (min new-x left)) 1201 (set! top (min new-y top)) 1202 (set! right (max new-x right)) 1203 (set! bottom (max new-y bottom))) 1204 (values left top right bottom)) 1205 1206 (define (pp->x p) 1207 (if (pulled-point? p) 1208 (pulled-point-x p) 1209 (point-x p))) 1210 1211 (define (pp->y p) 1212 (if (pulled-point? p) 1213 (pulled-point-y p) 1214 (point-y p))) 1215 1216 #| 1217 1218 the mask bitmap and the original bitmap are all together in a single bytes! 1219 1220 |# 1221 1222 1223 (define (get-bitmap-cache-key flip-bitmap) 1224 (define bm (flip-shape flip-bitmap)) 1225 (list (flip-flipped? flip-bitmap) 1226 (ibitmap-x-scale bm) 1227 (ibitmap-y-scale bm) 1228 (ibitmap-angle bm))) 1229 1230 (define (lookup/calc-rendered-bitmap flip-bitmap key) 1231 (let ([bitmap (flip-shape flip-bitmap)]) 1232 (cond 1233 [(hash-ref (ibitmap-cache bitmap) key #f) => values] 1234 [else 1235 (let ([flipped? (flip-flipped? flip-bitmap)]) 1236 (define orig-bitmap-obj (ibitmap-raw-bitmap bitmap)) 1237 (define bitmap-obj 1238 (cond 1239 [(<= (* (ibitmap-x-scale bitmap) 1240 (ibitmap-y-scale bitmap)) 1241 1) 1242 ;; since we prefer to rotate big things, we rotate first 1243 (do-scale bitmap (do-rotate bitmap orig-bitmap-obj flipped?))] 1244 [else 1245 ;; since we prefer to rotate big things, we scale first 1246 (do-rotate bitmap (do-scale bitmap orig-bitmap-obj) flipped?)])) 1247 (hash-set! (ibitmap-cache bitmap) key bitmap-obj) 1248 bitmap-obj)]))) 1249 1250 (define (do-rotate bitmap bitmap-obj flip?) 1251 (cond 1252 [(and (not flip?) (zero? (ibitmap-angle bitmap))) 1253 ;; don't rotate anything in this case. 1254 bitmap-obj] 1255 ;; speed up rotated (but not flipped) bitmaps 1256 [(not flip?) 1257 (define θ (degrees->radians (ibitmap-angle bitmap))) 1258 (define ow (send bitmap-obj get-width)) 1259 (define oh (send bitmap-obj get-height)) 1260 (define unrotated-pts 1261 (list (make-rectangular 0 0) 1262 (make-rectangular ow 0) 1263 (make-rectangular ow oh) 1264 (make-rectangular 0 oh))) 1265 (define pts (map (λ (p) (* p (make-polar 1 θ))) unrotated-pts)) 1266 (define longitudes (map real-part pts)) 1267 (define latitudes (map imag-part pts)) 1268 (define east (apply max longitudes)) 1269 (define west (apply min longitudes)) 1270 (define nrth (apply min latitudes)) 1271 (define sth (apply max latitudes)) 1272 (define new-w (ceiling (inexact->exact (- east west)))) 1273 (define new-h (ceiling (inexact->exact (- sth nrth)))) 1274 1275 (define new-bm (make-bitmap new-w new-h)) 1276 (define bdc (make-object bitmap-dc% new-bm)) 1277 (send bdc set-smoothing 'smoothed) 1278 (send bdc rotate (- θ)) 1279 1280 ;; would like to just translate by 'tp', but 1281 ;; the dc applies the translations before applying 1282 ;; the rotation, so we have to unrotate the translation 1283 ;; before telling the dc about it 1284 (define tp (make-rectangular (- west) (- nrth))) 1285 (define tp-translated (* tp (make-polar 1 (- θ)))) 1286 1287 (send bdc translate (real-part tp-translated) (imag-part tp-translated)) 1288 1289 (send bdc draw-bitmap bitmap-obj 0 0) 1290 (send bdc set-bitmap #f) 1291 new-bm] 1292 1293 [else 1294 (define θ (degrees->radians (ibitmap-angle bitmap))) 1295 (define-values (bytes w h) (bitmap->bytes bitmap-obj #f)) 1296 (define-values (rotated-bytes rotated-w rotated-h) (rotate-bytes bytes w h θ)) 1297 (define flipped-bytes (if flip? 1298 (flip-bytes rotated-bytes rotated-w rotated-h) 1299 rotated-bytes)) 1300 (define bm (bytes->bitmap flipped-bytes rotated-w rotated-h)) 1301 bm])) 1302 1303 (define (do-scale bitmap orig-bm) 1304 (define x-scale (ibitmap-x-scale bitmap)) 1305 (define y-scale (ibitmap-y-scale bitmap)) 1306 (cond 1307 [(and (= 1 x-scale) (= 1 y-scale)) 1308 ;; no need to scale in this case 1309 orig-bm] 1310 [else 1311 (define bdc (make-object bitmap-dc%)) 1312 (define orig-w (send orig-bm get-width)) 1313 (define orig-h (send orig-bm get-height)) 1314 (define scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))) 1315 (define scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))) 1316 (define new-bm (make-bitmap scale-w scale-h)) 1317 1318 (send bdc set-bitmap new-bm) 1319 (send bdc set-scale x-scale y-scale) 1320 (send bdc erase) 1321 (send bdc draw-bitmap orig-bm 0 0) 1322 1323 (send bdc set-bitmap #f) 1324 1325 new-bm])) 1326 1327 (define (text->font text) 1328 (define adjusted-size (min (max (inexact->exact (round (text-size text))) 1) 255)) 1329 (cond 1330 [(text-face text) 1331 (send the-font-list find-or-create-font 1332 adjusted-size 1333 (text-face text) 1334 (text-family text) 1335 (text-style text) 1336 (text-weight text) 1337 (text-underline text) 1338 'default 1339 #t)] 1340 [else 1341 (send the-font-list find-or-create-font 1342 adjusted-size 1343 (text-family text) 1344 (text-style text) 1345 (text-weight text) 1346 (text-underline text) 1347 'default 1348 #t)])) 1349 1350 (define (ellipse-rotated-size ew eh θ) 1351 (cond 1352 [(and (zero? ew) (zero? eh)) 1353 (values 0 0)] 1354 [(zero? eh) 1355 (values (* (cos θ) ew) 1356 (* (sin θ) ew))] 1357 [(zero? ew) 1358 (values (* (sin θ) eh) 1359 (* (cos θ) eh))] 1360 [else 1361 (let* ([t1 (atan (/ eh ew (exact->inexact (tan θ))))] 1362 ; a*cos(t1),b*sin(t1) is the point on *original* ellipse which gets rotated to top. 1363 [t2 (atan (/ (* (- eh) (tan θ)) ew))] ; the original point rotated to right side. 1364 [rotated-height (+ (* ew (sin θ) (cos t1)) (* eh (cos θ) (sin t1)))] 1365 [rotated-width (- (* ew (cos θ) (cos t2)) (* eh (sin θ) (sin t2)))]) 1366 (values (abs rotated-width) 1367 (abs rotated-height)))])) 1368 1369 (define (mode-color->smoothing mode color) 1370 (cond 1371 [(and (eq? mode 'outline) 1372 (not (pen? color))) 1373 'aligned] 1374 [else 'smoothed])) 1375 1376 (define (mode-color->pen mode color) 1377 (cond 1378 [(eq? mode 'outline) 1379 (cond 1380 [(pen? color) 1381 (pen->pen-obj/cache color)] 1382 [else 1383 (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])] 1384 [else 1385 (send the-pen-list find-or-create-pen "black" 1 'transparent)])) 1386 1387 (define (mode-color->brush mode color) 1388 (cond 1389 [(eq? mode 'outline) 1390 (send the-brush-list find-or-create-brush "black" 'transparent)] 1391 [else 1392 ;; this should only be 'solid if we have an old image from a save file somewhere 1393 (define extra-alpha (if (eq? mode 'solid) 1394 255 1395 mode)) 1396 (send the-brush-list find-or-create-brush (get-color-arg color extra-alpha) 'solid)])) 1397 1398 (define (get-color-arg color [extra-alpha 255]) 1399 (cond 1400 [(string? color) 1401 (define color-obj (string->color-object color)) 1402 (cond 1403 [(equal? color-obj transparent-color) transparent-color] 1404 [else 1405 (make-object color% 1406 (send color-obj red) 1407 (send color-obj green) 1408 (send color-obj blue) 1409 (/ extra-alpha 255))])] 1410 [else 1411 (make-object color% 1412 (color-red color) 1413 (color-green color) 1414 (color-blue color) 1415 (* (/ (color-alpha color) 255) 1416 (/ extra-alpha 255)))])) 1417 1418 (define extra-2htdp/image-colors 1419 (make-hash 1420 (list 1421 (cons "lightbrown" (make-object color% 183 111 87)) 1422 (cons "mediumbrown" (make-object color% 132 60 36)) 1423 (cons "darkbrown" (make-object color% 81 9 0)) 1424 (cons "mediumcyan" (make-object color% 0 255 255)) 1425 (cons "mediumgray" (make-object color% 190 190 190)) 1426 (cons "mediumgreen" (make-object color% 0 255 0)) 1427 (cons "lightorange" (make-object color% 255 216 51)) 1428 (cons "mediumorange" (make-object color% 255 165 0)) 1429 (cons "mediumpink" (make-object color% 255 192 203)) 1430 (cons "darkpink" (make-object color% 204 141 152)) 1431 (cons "lightpurple" (make-object color% 211 83 255)) 1432 (cons "darkpurple" (make-object color% 109 0 189)) 1433 (cons "lightred" (make-object color% 255 102 102)) 1434 (cons "mediumred" (make-object color% 255 0 0)) 1435 (cons "lightturquoise" (make-object color% 155 155 255)) 1436 (cons "mediumyellow" (make-object color% 255 255 0)) 1437 (cons "darkyellow" (make-object color% 204 204 0)) 1438 (cons "lightgoldenrod" (make-object color% 255 216 83)) 1439 (cons "transparent" (make-object color% 255 255 255 0))))) 1440 (define transparent-color (hash-ref extra-2htdp/image-colors "transparent")) 1441 1442 (define (string->color-object color) 1443 (or (string->color-object/f color) 1444 (send the-color-database find-color "black"))) 1445 (define (string->color-object/f color) 1446 (or (lookup-color color) 1447 (lookup-color (normalize-color-string color)))) 1448 (define (lookup-color color) 1449 (or (send the-color-database find-color color) 1450 (hash-ref extra-2htdp/image-colors color #f))) 1451 (define (normalize-color-string color) 1452 (define spaceless (regexp-replace* #rx" +" color "")) 1453 (define s (make-string (string-length spaceless))) 1454 (for ([i (in-naturals)] 1455 [c (in-string spaceless)]) 1456 (string-set! s i (char-foldcase c))) 1457 (regexp-replace #rx"grey" s "gray")) 1458 1459 (define (pen->pen-obj/cache pen) 1460 (send the-pen-list find-or-create-pen 1461 (get-color-arg (pen-color pen)) 1462 (pen-width pen) 1463 (pen-style pen) 1464 (pen-cap pen) 1465 (pen-join pen))) 1466 1467 (define (to-img arg) 1468 (cond 1469 [(is-a? arg image-snip%) (image-snip->image arg)] 1470 [(is-a? arg bitmap%) (bitmap->image arg)] 1471 [else arg])) 1472 1473 (define (image-snip->image is) 1474 (let ([bm (send is get-bitmap)]) 1475 (cond 1476 [(not bm) 1477 ;; this might mean we have a cache-image-snip% 1478 ;; or it might mean we have a useless snip. 1479 (let-values ([(w h) (if (is-a? is cis:cache-image-snip%) 1480 (send is get-size) 1481 (values 0 0))]) 1482 (make-image (construct-polygon 1483 (list (make-point 0 0) 1484 (make-point w 0) 1485 (make-point w h) 1486 (make-point 0 h)) 1487 'solid "black") 1488 (make-bb w h h) 1489 #f))] 1490 [else 1491 (bitmap->image bm 1492 (or (send is get-bitmap-mask) 1493 (send bm get-loaded-mask)))]))) 1494 1495 (define (construct-polygon points mode color) 1496 (make-polygon 1497 (for/list ([prev (in-list (cons (last points) points))] 1498 [p (in-list points)] 1499 [next (in-list (append (cdr points) (list (car points))))]) 1500 (cond 1501 [(point? p) 1502 (define x (point-x p)) 1503 (define y (point-y p)) 1504 (make-pulled-point 0 0 x y 0 0)] 1505 [else p])) 1506 mode color)) 1507 1508 (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)]) 1509 (define w (send bm get-width)) 1510 (define h (send bm get-height)) 1511 (define alpha-bm 1512 (cond 1513 [(send bm has-alpha-channel?) 1514 bm] 1515 [else 1516 (define new-bm (make-bitmap w h)) 1517 (define bdc (make-object bitmap-dc% new-bm)) 1518 (send bdc draw-bitmap bm 0 0 'solid 1519 (send the-color-database find-color "black") 1520 mask-bm) 1521 (send bdc set-bitmap #f) 1522 new-bm])) 1523 (make-image (make-translate (/ w 2) 1524 (/ h 2) 1525 (make-ibitmap alpha-bm 0 1 1 (make-hash))) 1526 (make-bb w h h) 1527 #f)) 1528 1529 (define bitmap-write-cache (make-parameter #f)) 1530 (define (bitmap-write bitmap port mode) 1531 (define v (struct->vector bitmap)) 1532 (define recur 1533 (case mode 1534 [(#t) write] 1535 [(#f) display] 1536 [else (lambda (p port) (print p port mode))])) 1537 1538 (define (to-bytes o) 1539 (define cache (bitmap-write-cache)) 1540 (define already-gotten-bytes (and cache (hash-ref cache o #f))) 1541 (cond 1542 [already-gotten-bytes already-gotten-bytes] 1543 [else 1544 (define res (call-with-values (λ () (bitmap->png-bytes o)) vector)) 1545 (when cache (hash-set! cache o res)) 1546 res])) 1547 1548 (define (update i) 1549 (define o (vector-ref v i)) 1550 (define nv (and o (to-bytes o))) 1551 (vector-set! v i nv)) 1552 1553 (update 1) 1554 ;; don't save the cache 1555 (vector-set! v 5 (make-hash)) 1556 (recur v port)) 1557 1558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1559 1560 1561 (provide make-image image-shape image-bb image-normalized? image% 1562 1563 un/cache-image compute-image-cache 1564 1565 (struct-out bb) 1566 (struct-out point) (struct-out pulled-point) build-pulled-point 1567 make-overlay overlay? overlay-top overlay-bottom 1568 make-translate translate? translate-dx translate-dy translate-shape 1569 make-scale scale? scale-x scale-y scale-shape 1570 make-crop crop? crop-points crop-shape 1571 make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color 1572 make-text text? text-string text-angle text-y-scale text-color 1573 text-angle text-size text-face text-family text-style text-weight text-underline 1574 (contract-out [rename construct-polygon make-polygon 1575 (-> (listof (or/c point? pulled-point?)) any/c any/c polygon?)]) 1576 polygon? polygon-points polygon-mode polygon-color 1577 make-line-segment line-segment? line-segment-start line-segment-end line-segment-color 1578 make-curve-segment curve-segment? 1579 curve-segment-start curve-segment-s-angle curve-segment-s-pull 1580 curve-segment-end curve-segment-e-angle curve-segment-e-pull 1581 curve-segment-mode curve-segment-color 1582 make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen 1583 1584 make-ibitmap ibitmap? ibitmap-raw-bitmap ibitmap-angle ibitmap-x-scale ibitmap-y-scale 1585 ibitmap-cache 1586 1587 make-flip flip? flip-flipped? flip-shape 1588 1589 (except-out (struct-out color) make-color) 1590 (rename-out [-make-color make-color]) 1591 1592 degrees->radians 1593 normalize-shape 1594 ellipse-rotated-size 1595 points->ltrb-values 1596 1597 image? 1598 1599 text->font 1600 render-image 1601 save-image-as-bitmap 1602 1603 skip-image-equality-fast-path 1604 render-normalized 1605 1606 scale-np-atomic 1607 1608 to-img 1609 bitmap->image 1610 image-snip->image 1611 image-snip% 1612 1613 curve-segment->path 1614 mode-color->pen 1615 1616 snipclass-bytes->image 1617 image->snipclass-bytes 1618 (contract-out 1619 [definitely-same-image? (-> image? image? boolean?)]) 1620 string->color-object/f 1621 extra-2htdp/image-colors) 1622 1623 ;; method names 1624 (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) 1625 1626 (provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?)