1#lang racket/base 2 3(require mrlib/image-core 4 "img-err.rkt" 5 racket/match 6 racket/contract 7 racket/class 8 (except-in racket/draw 9 make-pen make-color) 10 ;(only-in racket/gui/base frame% canvas% slider% horizontal-panel% button%) 11 htdp/error 12 racket/math 13 racket/string 14 (for-syntax racket/base 15 racket/list) 16 lang/posn 17 net/url) 18(module+ test (require rackunit)) 19 20(define 2pi (* 2 pi)) 21 22;; for testing 23; (require racket/gui/base) 24#; 25(define (show-image arg [extra-space 0]) 26 (letrec ([g (to-img arg)] 27 [f (new frame% [label ""])] 28 [c (new canvas% 29 [parent f] 30 [min-width (+ extra-space (image-width g))] 31 [min-height (+ extra-space (image-height g))] 32 [paint-callback 33 (λ (c dc) 34 (send dc set-smoothing 'aligned) 35 (let-values ([(w h) (send c get-client-size)]) 36 (let ([scale (send sl get-value)]) 37 (send dc set-scale scale scale) 38 (render-image 39 g 40 dc 41 (inexact->exact (floor (- (/ w 2 scale) (/ (get-right g) 2)))) 42 (inexact->exact (floor (- (/ h 2 scale) (/ (get-bottom g) 2))))))))])] 43 [min-scale 1] 44 [max-scale 10] 45 [sl (new slider% 46 [label "Scale factor"] 47 [parent f] 48 [min-value min-scale] 49 [max-value max-scale] 50 [callback (λ ignore (send c refresh))])] 51 [bp (new horizontal-panel% 52 [parent f] 53 [alignment '(center center)] 54 [stretchable-height #f])] 55 [scale-adjust 56 (λ (f) 57 (send sl set-value 58 (max min-scale (min max-scale (f (send sl get-value))))) 59 (send c refresh))]) 60 (send (new button% 61 [label "√"] 62 [callback (λ x (scale-adjust sub1))] 63 [parent bp]) min-width 100) 64 (send (new button% 65 [label "2"] 66 [callback (λ x (scale-adjust add1))] 67 [parent bp]) min-width 100) 68 (send f show #t))) 69 70;; the obfuscation in the width and height defaults 71;; is so that error checking happens in the right order 72(define/chk (save-image image 73 filename 74 [width (if (image? image) (image-width image) 0)] 75 [height (if (image? image) (image-height image) 0)]) 76 (check-dependencies 'save-image 77 (not (zero? width)) 78 "the width must not be zero, got ~e" 79 width) 80 (check-dependencies 'save-image 81 (not (zero? height)) 82 "the width must not be zero, got ~e" 83 height) 84 (let* ([bm (make-bitmap (inexact->exact (ceiling width)) 85 (inexact->exact (ceiling height)))] 86 [bdc (make-object bitmap-dc% bm)]) 87 (send bdc set-smoothing 'aligned) 88 (send bdc erase) 89 (render-image image bdc 0 0) 90 (send bdc set-bitmap #f) 91 (send bm save-file filename 'png))) 92 93(define/chk (save-svg-image image 94 filename 95 [width (if (image? image) (image-width image) 0)] 96 [height (if (image? image) (image-height image) 0)]) 97 (call-with-output-file filename 98 (λ (port) 99 (define sdc (new svg-dc% [width width] [height height] [output port])) 100 (send sdc start-doc "") 101 (send sdc start-page) 102 (send sdc set-smoothing 'aligned) 103 (render-image image sdc 0 0) 104 (send sdc end-page) 105 (send sdc end-doc)) 106 #:exists 'truncate)) 107 108(define (get-right img) (bb-right (send img get-bb))) 109(define (get-bottom img) (bb-bottom (send img get-bb))) 110(define (get-baseline img) (bb-baseline (send img get-bb))) 111 112; 113; 114; 115; ;; 116; ;; 117; ;; 118; ;;;; ;;; ;;;;;; ;; ; ;; ;;;;; ;;; ; 119; ;; ;; ;; ;;;; ;; ;;;; ;; ; ;; ;; ;; 120; ;;; ;; ;;;; ;;;;;; ;; ;; ;;;; ;;;; 121; ;;; ;; ;;;; ;; ;; ;; ;; ;; ;;; 122; ;; ;; ;;; ;;; ; ;; ;; ;; ;; ;;; 123; ;;;; ;; ;;;; ;; ;; ;;;;;;; ;; 124; ;; 125; ; 126; ;; 127 128 129;; scale : number image -> image 130(define/chk (scale factor image) 131 (scale-internal factor factor image)) 132 133(define/chk (scale/xy x-factor y-factor image) 134 (scale-internal x-factor y-factor image)) 135 136(define (scale-internal x-factor y-factor image) 137 (let ([ph (send image get-pinhole)]) 138 (make-image (make-scale x-factor y-factor (image-shape image)) 139 (make-bb (* x-factor (get-right image)) 140 (* y-factor (get-bottom image)) 141 (* y-factor (get-baseline image))) 142 #f 143 (and ph 144 (make-point (* x-factor (point-x ph)) 145 (* y-factor (point-y ph))))))) 146 147;; overlay : image image image ... -> image 148;; places images on top of each other with their upper left corners aligned. 149;; last one goes on the bottom 150(define/chk (overlay image image2 . image3) 151 (overlay/internal 'middle 'middle image (cons image2 image3) #t)) 152 153;; underlay : image image image ... -> image 154(define/chk (underlay image image2 . image3) 155 (let ([imgs (reverse (list* image image2 image3))]) 156 (overlay/internal 'middle 'middle (car imgs) (cdr imgs) #f))) 157 158;; overlay/align : string string image image image ... -> image 159;; the first string has to be one of "center" "middle" "left" or "right" (or symbols) 160;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols) 161;; behaves like overlay, but lines up the images in the various places. 162;; overlay without string arguments is the same as passing "left" and "top" 163;; for the two string arguments. Passing, eg, "center" "center" lines the 164;; images up at their centers. 165 166(define/chk (overlay/align x-place y-place image image2 . image3) 167 (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) 168 (check-dependencies 169 'overlay/align 170 (and (send image get-pinhole) 171 (send image2 get-pinhole) 172 (andmap (λ (x) (send x get-pinhole)) 173 image3)) 174 "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" 175 'pinhole "pinhole")) 176 (overlay/internal x-place y-place image (cons image2 image3) #t)) 177 178(define/chk (underlay/align x-place y-place image image2 . image3) 179 (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) 180 (check-dependencies 181 'underlay/align 182 (and (send image get-pinhole) 183 (send image2 get-pinhole) 184 (andmap (λ (x) (send x get-pinhole)) 185 image3)) 186 "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" 187 'pinhole "pinhole")) 188 (let ([imgs (reverse (list* image image2 image3))]) 189 (overlay/internal x-place y-place (car imgs) (cdr imgs) #f))) 190 191(define/chk (overlay/pinhole image1 image2 . image3) 192 (overlay/internal 'pinhole 'pinhole 193 (maybe-center-pinhole image1) 194 (map maybe-center-pinhole (cons image2 image3)) 195 #t)) 196 197(define/chk (underlay/pinhole image1 image2 . image3) 198 (let ([imgs (map maybe-center-pinhole (reverse (list* image1 image2 image3)))]) 199 (overlay/internal 'pinhole 'pinhole 200 (car imgs) 201 (cdr imgs) 202 #f))) 203 204(define (maybe-center-pinhole img) 205 (if (send img get-pinhole) 206 img 207 (center-pinhole img))) 208 209(define (overlay/internal x-place y-place fst rst first-pinhole?) 210 (let loop ([fst fst] 211 [rst rst]) 212 (cond 213 [(null? rst) fst] 214 [else 215 (let* ([fst-x-spot (find-x-spot x-place fst)] 216 [fst-y-spot (find-y-spot y-place fst)] 217 [snd-x-spot (find-x-spot x-place (car rst))] 218 [snd-y-spot (find-y-spot y-place (car rst))] 219 [dx (- fst-x-spot snd-x-spot)] 220 [dy (- fst-y-spot snd-y-spot)]) 221 (loop (overlay/δ fst 222 (if (< dx 0) (- dx) 0) 223 (if (< dy 0) (- dy) 0) 224 (car rst) 225 (if (< dx 0) 0 dx) 226 (if (< dy 0) 0 dy) 227 first-pinhole? 228 #f) 229 (cdr rst)))]))) 230 231(define (find-x-spot x-place image) 232 (case x-place 233 [(left) 0] 234 [(middle) (/ (get-right image) 2)] 235 [(right) (get-right image)] 236 [(pinhole) (point-x (send image get-pinhole))] 237 [else (error 'find-x-spot "~s" x-place)])) 238 239(define (find-y-spot y-place image) 240 (case y-place 241 [(top) 0] 242 [(middle) (/ (get-bottom image) 2)] 243 [(bottom) (get-bottom image)] 244 [(baseline) (get-baseline image)] 245 [(pinhole) (point-y (send image get-pinhole))] 246 [else (error 'find-y-spot "~s" y-place)])) 247 248;; overlay/xy : image number number image -> image 249;; places images on top of each other with their upper-left corners offset by the two numbers 250 251(define/chk (overlay/xy image dx dy image2) 252 (overlay/δ image 253 (if (< dx 0) (- dx) 0) 254 (if (< dy 0) (- dy) 0) 255 image2 256 (if (< dx 0) 0 dx) 257 (if (< dy 0) 0 dy) 258 #t 259 #f)) 260 261(define/chk (underlay/xy image dx dy image2) 262 (overlay/δ image2 263 (if (< dx 0) 0 dx) 264 (if (< dy 0) 0 dy) 265 image 266 (if (< dx 0) (- dx) 0) 267 (if (< dy 0) (- dy) 0) 268 #f 269 #f)) 270 271(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2 first-pinhole? beside-baseline?) 272 (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1)) 273 (make-translate dx2 dy2 (image-shape image2))) 274 (make-bb (max (+ (get-right image1) dx1) 275 (+ (get-right image2) dx2)) 276 (max (+ (get-bottom image1) dy1) 277 (+ (get-bottom image2) dy2)) 278 (if beside-baseline? 279 (let ([δ1 (- (get-bottom image1) (get-baseline image1))] 280 [δ2 (- (get-bottom image2) (get-baseline image2))] 281 [b1 (+ (get-baseline image1) dy1)] 282 [b2 (+ (get-baseline image2) dy2)]) 283 (cond 284 [(= δ1 δ2) (max b1 b2)] 285 [(< δ1 δ2) b2] 286 [else b1])) 287 (max (+ (get-baseline image1) dy1) 288 (+ (get-baseline image2) dy2)))) 289 #f 290 (if first-pinhole? 291 (let ([ph (send image1 get-pinhole)]) 292 (and ph 293 (make-point (+ (point-x ph) dx1) 294 (+ (point-y ph) dy1)))) 295 (let ([ph (send image2 get-pinhole)]) 296 (and ph 297 (make-point (+ (point-x ph) dx2) 298 (+ (point-y ph) dy2))))))) 299 300;; beside : image image image ... -> image 301;; places images in a single horizontal row, top aligned 302(define/chk (beside image1 image2 . image3) 303 (beside/internal 'middle image1 (cons image2 image3))) 304 305;; beside/align : string image image image ... -> image 306;; places images in a horizontal row where the vertical alignment is 307;; covered by the string argument 308(define/chk (beside/align y-place image1 image2 . image3) 309 (when (eq? y-place 'pinhole) 310 (check-dependencies 'beside/align 311 (and (send image1 get-pinhole) 312 (send image2 get-pinhole) 313 (andmap (λ (x) (send x get-pinhole)) 314 image3)) 315 "when y-place is ~e or ~e, then all of the arguments must have pinholes" 316 'pinhole "pinhole")) 317 (beside/internal y-place image1 (cons image2 image3))) 318 319(define (beside/internal y-place fst rst) 320 (let loop ([fst fst] 321 [rst rst]) 322 (cond 323 [(null? rst) fst] 324 [else 325 (let* ([snd (car rst)] 326 [fst-y-spot (find-y-spot y-place fst)] 327 [snd-y-spot (find-y-spot y-place (car rst))] 328 [dy (- fst-y-spot snd-y-spot)]) 329 (loop (overlay/δ fst 330 0 331 (if (< dy 0) (- dy) 0) 332 (car rst) 333 (get-right fst) 334 (if (< dy 0) 0 dy) 335 #t 336 #t) 337 (cdr rst)))]))) 338 339;; above : image image image ... -> image 340;; places images in a single vertical row, left aligned 341(define/chk (above image1 image2 . image3) 342 (above/internal 'middle image1 (cons image2 image3))) 343 344;; beside/align : string image image image ... -> image 345;; places images in a horizontal row where the vertical alignment is 346;; covered by the string argument 347(define/chk (above/align x-place image1 image2 . image3) 348 (when (eq? x-place 'pinhole) 349 (check-dependencies 'above/align 350 (and (send image1 get-pinhole) 351 (send image2 get-pinhole) 352 (andmap (λ (x) (send x get-pinhole)) 353 image3)) 354 "when x-place is ~e or ~e, then all of the arguments must have pinholes" 355 'pinhole "pinhole")) 356 (above/internal x-place image1 (cons image2 image3))) 357 358(define (above/internal x-place fst rst) 359 (let loop ([fst fst] 360 [rst rst]) 361 (cond 362 [(null? rst) fst] 363 [else 364 (let* ([snd (car rst)] 365 [fst-x-spot (find-x-spot x-place fst)] 366 [snd-x-spot (find-x-spot x-place (car rst))] 367 [dx (- fst-x-spot snd-x-spot)]) 368 (loop (overlay/δ fst 369 (if (< dx 0) (- dx) 0) 370 0 371 (car rst) 372 (if (< dx 0) 0 dx) 373 (get-bottom fst) 374 #t 375 #f) 376 (cdr rst)))]))) 377 378(define/chk (overlay/offset image1 dx dy image2) 379 (overlay/offset/internal 'middle 'middle image1 dx dy image2)) 380 381(define/chk (overlay/align/offset x-place y-place image1 dx dy image2) 382 (overlay/offset/internal x-place y-place image1 dx dy image2)) 383 384(define/chk (underlay/offset image1 dx dy image2) 385 (overlay/offset/internal 'middle 'middle image2 (- dx) (- dy) image1)) 386 387(define/chk (underlay/align/offset x-place y-place image1 dx dy image2) 388 (overlay/offset/internal x-place y-place image2 (- dx) (- dy) image1)) 389 390(define (overlay/offset/internal x-place y-place fst orig-dx orig-dy snd) 391 (let* ([fst-x-spot (find-x-spot x-place fst)] 392 [fst-y-spot (find-y-spot y-place fst)] 393 [snd-x-spot (find-x-spot x-place snd)] 394 [snd-y-spot (find-y-spot y-place snd)] 395 [dx (+ (- fst-x-spot snd-x-spot) orig-dx)] 396 [dy (+ (- fst-y-spot snd-y-spot) orig-dy)]) 397 (overlay/δ fst 398 (if (< dx 0) (- dx) 0) 399 (if (< dy 0) (- dy) 0) 400 snd 401 (if (< dx 0) 0 dx) 402 (if (< dy 0) 0 dy) 403 #t 404 #f))) 405 406 407; 408; 409; 410; ;;;; ;; ; 411; ;;;; ;; ;; 412; ;;;;; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;; ;;; ;;;;;;; ;;;;; ;;;; ;;; ;;; ;;;;; 413; ;;;;;; ;;;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;; ;;;;;;;;; ;;;;;;;; ;;;;;; ;;;;;; ;;;;;;; ;;;;;; 414; ;;;;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;;; ;;;; ;; ;;;; 415; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;; ;;;; ;;;; 416; ;;;;;;; ;;;;;;;; ;;;; ;;; ;;;; ;;;;;;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;;; ;;;;;;;; ;;;; ;;;; 417; ;;;;;; ;;;;;; ;;;; ;;; ;;;; ;;;;;;;; ;;;; ;;;; ;;;; ;;;;;;;; ;;;;; ;;;;;; ;;;; ;;;;;; 418; ;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;; ;;;; ;;;; ;;;; ;;;; ;;;;; 419; 420; 421; 422 423 424;; crop : number number number number image -> image 425;; crops an image to be w x h from (x,y) 426(define/chk (crop x1 y1 width height image) 427 (crop/internal x1 y1 width height image)) 428 429(define/chk (crop/align x-place y-place width height image) 430 (define x-spot (find-x-spot x-place image)) 431 (define y-spot (find-y-spot y-place image)) 432 (define crop-rec (rectangle width height "solid" "black")) 433 (define w-off (find-x-spot x-place crop-rec)) 434 (define h-off (find-y-spot y-place crop-rec)) 435 (crop/internal (- x-spot w-off) 436 (- y-spot h-off) 437 width height image)) 438 439(define (crop/internal x1 y1 width height image) 440 (let ([points (rectangle-points width height)] 441 [ph (send image get-pinhole)]) 442 (make-image (make-crop points 443 (make-translate (- x1) (- y1) (image-shape image))) 444 (make-bb width 445 height 446 (min height (get-baseline image))) 447 #f 448 (and ph 449 (make-point (- (point-x ph) x1) 450 (- (point-y ph) y1)))))) 451 452;; place-image : image x y scene -> scene 453(define/chk (place-image image1 x1 y1 image2) 454 (place-image/internal image1 x1 y1 image2 'middle 'middle)) 455(define/chk (place-image/align image1 x1 y1 x-place y-place image2) 456 (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) 457 (check-dependencies 458 'place-image/align 459 (send image1 get-pinhole) 460 "when x-place or y-place is ~e or ~e, the the first image argument must have a pinhole" 461 'pinhole "pinhole")) 462 (place-image/internal image1 x1 y1 image2 x-place y-place)) 463(define/chk (place-images images zero-or-more-posns image2) 464 (check-place-images-dependency 'place-images images zero-or-more-posns) 465 (for/fold ([image2 image2]) ([image1 (in-list (reverse images))] 466 [posn (in-list (reverse zero-or-more-posns))]) 467 (place-image/internal 468 image1 (posn-x posn) (posn-y posn) image2 'middle 'middle))) 469(define/chk (place-images/align images zero-or-more-posns x-place y-place image2) 470 (check-place-images-dependency 'place-images/align images zero-or-more-posns) 471 (for/fold ([image2 image2]) ([image1 (in-list (reverse images))] 472 [posn (in-list (reverse zero-or-more-posns))]) 473 (place-image/internal 474 image1 (posn-x posn) (posn-y posn) image2 x-place y-place))) 475 476(define/chk (put-image image1 x1 y1 image2) 477 (place-image/internal image1 x1 (- (image-height image2) y1) image2 478 'middle 'middle)) 479 480(define (check-place-images-dependency who images zero-or-more-posns) 481 (check-dependencies who 482 (= (length images) (length zero-or-more-posns)) 483 "expected images and posns arguments to have the same length")) 484 485(define (place-image/internal image orig-dx orig-dy scene x-place y-place) 486 (let ([dx (- orig-dx (find-x-spot x-place image))] 487 [dy (- orig-dy (find-y-spot y-place image))]) 488 (crop/internal 489 (if (< dx 0) (- dx) 0) 490 (if (< dy 0) (- dy) 0) 491 (get-right scene) 492 (get-bottom scene) 493 (overlay/δ image 494 (if (< dx 0) 0 dx) 495 (if (< dy 0) 0 dy) 496 scene 497 (if (< dx 0) (- dx) 0) 498 (if (< dy 0) (- dy) 0) 499 #f 500 #f)))) 501 502(define/chk (scene+line image x1 y1 x2 y2 color) 503 (make-image (make-overlay 504 (make-crop (rectangle-points (get-right image) (get-bottom image)) 505 (make-line-segment (make-point x1 y1) (make-point x2 y2) color)) 506 (image-shape image)) 507 (image-bb image) 508 #f 509 (send image get-pinhole))) 510 511(define/chk (scene+polygon image posns-or-pulled-points mode color) 512 (check-mode/color-combination 'scene+polygon 4 mode color) 513 (make-image (make-overlay 514 (make-crop (rectangle-points (get-right image) (get-bottom image)) 515 (make-polygon (map (λ (p) 516 (cond 517 [(posn? p) 518 (make-point (posn-x p) (posn-y p))] 519 [else p])) 520 posns-or-pulled-points) 521 mode color)) 522 (image-shape image)) 523 (image-bb image) 524 #f 525 (send image get-pinhole))) 526 527 528(define/chk (scene+curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color) 529 (make-image (make-overlay 530 (make-crop (rectangle-points (get-right image) (get-bottom image)) 531 (make-curve-segment (make-point x1 y1) angle1 pull1 532 (make-point x2 y2) angle2 pull2 533 'outline color)) 534 (image-shape image)) 535 (image-bb image) 536 #f 537 (send image get-pinhole))) 538 539;; frame : image -> image 540;; draws a black frame around a image where the bounding box is 541;; (useful for debugging images) 542 543(define/chk (frame image) (real-color-frame "black" image)) 544(define/chk (color-frame color image) (real-color-frame color image)) 545 546(define (real-color-frame color image) 547 (make-image (make-overlay (image-shape 548 (crop 0 0 549 (get-right image) 550 (get-bottom image) 551 (rectangle (get-right image) 552 (get-bottom image) 553 'outline 554 (pen color 2 'solid 'round 'round)))) 555 (image-shape image)) 556 (make-bb (get-right image) 557 (get-bottom image) 558 (get-baseline image)) 559 #f 560 (send image get-pinhole))) 561 562;; scale : I number -> I 563;; scales the I by the given factor 564 565;; rotate : number I -> I 566;; rotates the I around the top-left corner by the given angle (in degrees) 567(define/chk (rotate angle image) 568 (let* ([rotated-shape (rotate-normalized-shape 569 angle 570 (send image get-normalized-shape))] 571 [ltrb (normalized-shape-bb rotated-shape)] 572 [ph (send image get-pinhole)]) 573 (make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) rotated-shape) 574 (make-bb (- (ltrb-right ltrb) (ltrb-left ltrb)) 575 (- (ltrb-bottom ltrb) (ltrb-top ltrb)) 576 (- (ltrb-bottom ltrb) (ltrb-top ltrb))) 577 #f 578 (and ph 579 (let ([rp (rotate-point ph angle)]) 580 (make-point (- (point-x rp) (ltrb-left ltrb)) 581 (- (point-y rp) (ltrb-top ltrb)))))))) 582 583(define/contract (rotate-normalized-shape angle shape) 584 (-> number? normalized-shape? normalized-shape?) 585 (cond 586 [(overlay? shape) 587 (let ([top-shape (rotate-normalized-shape angle (overlay-top shape))] 588 [bottom-shape (rotate-cn-or-simple-shape angle (overlay-bottom shape))]) 589 (make-overlay top-shape bottom-shape))] 590 [else 591 (rotate-cn-or-simple-shape angle shape)])) 592 593(define/contract (rotate-cn-or-simple-shape angle shape) 594 (-> number? cn-or-simple-shape? cn-or-simple-shape?) 595 (cond 596 [(crop? shape) 597 (make-crop (rotate-points (crop-points shape) angle) 598 (rotate-normalized-shape angle (crop-shape shape)))] 599 [else 600 (rotate-simple angle shape)])) 601 602;; rotate-simple : angle simple-shape -> simple-shape 603(define/contract (rotate-simple θ simple-shape) 604 (-> number? simple-shape? simple-shape?) 605 (cond 606 [(line-segment? simple-shape) 607 (make-line-segment (rotate-point (line-segment-start simple-shape) 608 θ) 609 (rotate-point (line-segment-end simple-shape) 610 θ) 611 (line-segment-color simple-shape))] 612 [(curve-segment? simple-shape) 613 (make-curve-segment (rotate-point (curve-segment-start simple-shape) 614 θ) 615 (bring-between (+ (curve-segment-s-angle simple-shape) θ) 360) 616 (curve-segment-s-pull simple-shape) 617 (rotate-point (curve-segment-end simple-shape) 618 θ) 619 (bring-between (+ (curve-segment-e-angle simple-shape) θ) 360) 620 (curve-segment-e-pull simple-shape) 621 (curve-segment-mode simple-shape) 622 (curve-segment-color simple-shape))] 623 [(polygon? simple-shape) 624 (make-polygon (rotate-points (polygon-points simple-shape) θ) 625 (polygon-mode simple-shape) 626 (polygon-color simple-shape))] 627 [else 628 (let* ([unrotated (translate-shape simple-shape)] 629 [rotated (rotate-atomic θ unrotated)]) 630 (let-values ([(dx dy) 631 (c->xy (* (degrees->complex θ) 632 (xy->c (translate-dx simple-shape) 633 (translate-dy simple-shape))))]) 634 (make-translate dx dy rotated)))])) 635 636(struct ltrb (left top right bottom) #:transparent) 637(define (union-ltrb ltrb1 ltrb2) 638 (ltrb (min (ltrb-left ltrb1) (ltrb-left ltrb2)) 639 (min (ltrb-top ltrb1) (ltrb-top ltrb2)) 640 (max (ltrb-right ltrb1) (ltrb-right ltrb2)) 641 (max (ltrb-bottom ltrb1) (ltrb-bottom ltrb2)))) 642 643;; only intersection if they already overlap. 644(define (intersect-ltrb ltrb1 ltrb2) 645 (ltrb (max (ltrb-left ltrb1) (ltrb-left ltrb2)) 646 (max (ltrb-top ltrb1) (ltrb-top ltrb2)) 647 (min (ltrb-right ltrb1) (ltrb-right ltrb2)) 648 (min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2)))) 649 650(define/contract (normalized-shape-bb shape) 651 (-> normalized-shape? ltrb?) 652 (cond 653 [(overlay? shape) 654 (let ([top-ltrb (normalized-shape-bb (overlay-top shape))] 655 [bottom-ltrb (cn-or-simple-shape-bb (overlay-bottom shape))]) 656 (union-ltrb top-ltrb bottom-ltrb))] 657 [else 658 (cn-or-simple-shape-bb shape)])) 659 660(define/contract (cn-or-simple-shape-bb shape) 661 (-> cn-or-simple-shape? ltrb?) 662 (cond 663 [(crop? shape) 664 (let ([ltrb (normalized-shape-bb (crop-shape shape))] 665 [crop-ltrb (points->ltrb (crop-points shape))]) 666 (intersect-ltrb crop-ltrb ltrb))] 667 [else 668 (simple-bb shape)])) 669 670;; simple-bb : simple-shape -> ltrb 671;; returns the bounding box of 'shape' 672;; (only called for rotated shapes, so bottom=baseline) 673(define/contract (simple-bb simple-shape) 674 (-> simple-shape? ltrb?) 675 (cond 676 [(line-segment? simple-shape) 677 (let ([x1 (point-x (line-segment-start simple-shape))] 678 [y1 (point-y (line-segment-start simple-shape))] 679 [x2 (point-x (line-segment-end simple-shape))] 680 [y2 (point-y (line-segment-end simple-shape))]) 681 (ltrb (min x1 x2) 682 (min y1 y2) 683 (+ (max x1 x2) 1) 684 (+ (max y1 y2) 1)))] 685 [(curve-segment? simple-shape) 686 (let ([x1 (point-x (curve-segment-start simple-shape))] 687 [y1 (point-y (curve-segment-start simple-shape))] 688 [x2 (point-x (curve-segment-end simple-shape))] 689 [y2 (point-y (curve-segment-end simple-shape))]) 690 (ltrb (min x1 x2) 691 (min y1 y2) 692 (+ (max x1 x2) 1) 693 (+ (max y1 y2) 1)))] 694 [(polygon? simple-shape) 695 (points->ltrb (polygon-points simple-shape))] 696 [else 697 (let ([dx (translate-dx simple-shape)] 698 [dy (translate-dy simple-shape)]) 699 (let-values ([(l t r b) (np-atomic-bb (translate-shape simple-shape))]) 700 (ltrb (+ l dx) 701 (+ t dy) 702 (+ r dx) 703 (+ b dy))))])) 704 705(define (points->ltrb points) 706 (let-values ([(left top right bottom) (points->ltrb-values points)]) 707 (ltrb left top right bottom))) 708 709(define/contract (np-atomic-bb atomic-shape) 710 (-> np-atomic-shape? (values number? number? number? number?)) 711 (cond 712 [(ellipse? atomic-shape) 713 (define ew (ellipse-width atomic-shape)) 714 (define eh (ellipse-height atomic-shape)) 715 (define wedge (ellipse-wedge atomic-shape)) 716 (define θ (degrees->radians (ellipse-angle atomic-shape))) 717 (cond 718 [wedge 719 ;; this code assumes that ew and eh are never zero, 720 ;; something that should be guaranteed by the way 721 ;; ellipses are constructed 722 (define (point-on-ellipse t) 723 (list (ellipse-t->x ew eh θ t) 724 (ellipse-t->y ew eh θ t))) 725 (define (in-range-point-on-ellipse t) 726 (and (is-between? 0 t wedge-θ) 727 (point-on-ellipse t))) 728 (define out-θ-x (ellipse-outermost-point-x ew eh θ)) 729 (define out-θ-y (ellipse-outermost-point-y ew eh θ)) 730 (define wedge-θ (degrees->radians wedge)) 731 (define points-to-consider 732 (combine-points-to-consider 733 (list 0 0) ;; center point 734 (point-on-ellipse wedge-θ) ;; end of wedge 735 (point-on-ellipse (degrees->radians 0)) ;; start of wedge 736 737 ;; widest points on the ellipse (but only if they are in range) 738 (in-range-point-on-ellipse out-θ-x) 739 (in-range-point-on-ellipse out-θ-y) 740 (in-range-point-on-ellipse (+ pi out-θ-x)) 741 (in-range-point-on-ellipse (+ pi out-θ-y)) 742 )) 743 (define xs (map car points-to-consider)) 744 (define ys (map cadr points-to-consider)) 745 (define l (apply min xs)) 746 (define r (apply max xs)) 747 (define t (apply min ys)) 748 (define b (apply max ys)) 749 (values l t r b)] 750 [else 751 (define-values (w h) 752 (ellipse-rotated-size ew eh θ)) 753 754 (values (- (/ w 2)) 755 (- (/ h 2)) 756 (/ w 2) 757 (/ h 2))])] 758 [(text? atomic-shape) 759 (let-values ([(w h a d) (send text-sizing-bm get-text-extent 760 (text-string atomic-shape) 761 (text->font atomic-shape))]) 762 (rotated-rectangular-bounding-box w h (text-angle atomic-shape)))] 763 [(flip? atomic-shape) 764 (define bitmap (flip-shape atomic-shape)) 765 (define bb (ibitmap-raw-bitmap bitmap)) 766 (define-values (l t r b) 767 (rotated-rectangular-bounding-box (* (send bb get-width) (ibitmap-x-scale bitmap)) 768 (* (send bb get-height) (ibitmap-y-scale bitmap)) 769 (ibitmap-angle bitmap))) 770 (values l t r b)] 771 [else 772 (eprintf "using bad bounding box for ~s\n" atomic-shape) 773 (values 0 0 100 100)])) 774 775;; returns #true if θ2 is between θ1 and θ3 776;; θ1 =/= θ3 (as angles) 777(define (is-between? θ1 θ2 θ3) 778 (define (bring-in-range θ) 779 (cond 780 [(and (<= 0 θ) (< θ 2pi)) θ] 781 [(< θ 0) 782 (bring-in-range (+ θ 2pi))] 783 [else 784 (bring-in-range (- θ 2pi))])) 785 (define θ1r (bring-in-range θ1)) 786 (define θ2r (bring-in-range θ2)) 787 (define θ3r (bring-in-range θ3)) 788 (cond 789 [(<= θ1r θ3r) (<= θ1r θ2r θ3r)] 790 [else (not (<= θ3r θ2r θ1r))])) 791(module+ test 792 (check-equal? (is-between? 0 pi (* 3/2 pi)) #t) 793 (check-equal? (is-between? 0 pi (* 1/2 pi)) #f) 794 (check-equal? (is-between? (* 1/6 pi) (* 3/6 pi) (* 5/6 pi)) #t) 795 (check-equal? (is-between? (* 1/6 pi) (* 7/6 pi) (* 5/6 pi)) #f) 796 (check-equal? (is-between? (* 5/6 pi) (* 3/6 pi) (* 1/6 pi)) #f) 797 (check-equal? (is-between? (* 5/6 pi) (* 7/6 pi) (* 1/6 pi)) #t) 798 (check-equal? (is-between? (* 1/2 pi) pi 2pi) #t) 799 (check-equal? (is-between? (* 1/2 pi) (* 1/4 pi) 2pi) #f)) 800 801;; combine-points-to-consider : (or/c #f (cons/c number? number?)) -> (listof (cons/c number? number?)) 802(define (combine-points-to-consider . xs) 803 (for/fold ([l '()]) ([x (in-list xs)]) 804 (if x (cons x l) l))) 805 806(define (rotated-rectangular-bounding-box w h θ) 807 (let*-values ([(ax ay) (rotate-xy (- (/ w 2)) (- (/ h 2)) θ)] 808 [(bx by) (rotate-xy (- (/ w 2)) (/ h 2) θ)] 809 [(cx cy) (rotate-xy (/ w 2) (- (/ h 2)) θ)] 810 [(dx dy) (rotate-xy (/ w 2) (/ h 2) θ)]) 811 (values (min ax bx cx dx) 812 (min ay by cy dy) 813 (max ax bx cx dx) 814 (max ay by cy dy)))) 815 816(define (center-point np-atomic-shape) 817 (let-values ([(l t r b) (np-atomic-bb np-atomic-shape)]) 818 (xy->c (/ (- r l) 2) 819 (/ (- b t) 2)))) 820 821;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape 822(define (rotate-atomic θ atomic-shape) 823 (-> number? np-atomic-shape? np-atomic-shape?) 824 (cond 825 [(ellipse? atomic-shape) 826 (cond 827 [(ellipse-wedge atomic-shape) 828 ;; we don't have the symmetry in the case below when we are a wedge 829 (define new-angle (bring-between (+ θ (ellipse-angle atomic-shape)) 360)) 830 (make-ellipse (ellipse-width atomic-shape) 831 (ellipse-height atomic-shape) 832 new-angle 833 (ellipse-mode atomic-shape) 834 (ellipse-color atomic-shape) 835 (ellipse-wedge atomic-shape))] 836 [else 837 (define new-angle (bring-between (+ θ (ellipse-angle atomic-shape)) 180)) 838 (cond 839 [(= (ellipse-width atomic-shape) 840 (ellipse-height atomic-shape)) 841 atomic-shape] 842 [(< new-angle 90) 843 (make-ellipse (ellipse-width atomic-shape) 844 (ellipse-height atomic-shape) 845 new-angle 846 (ellipse-mode atomic-shape) 847 (ellipse-color atomic-shape) 848 (ellipse-wedge atomic-shape))] 849 [else 850 (make-ellipse (ellipse-height atomic-shape) 851 (ellipse-width atomic-shape) 852 (- new-angle 90) 853 (ellipse-mode atomic-shape) 854 (ellipse-color atomic-shape) 855 (ellipse-wedge atomic-shape))])])] 856 [(text? atomic-shape) 857 (make-text (text-string atomic-shape) 858 (bring-between (+ θ (text-angle atomic-shape)) 360) 859 (text-y-scale atomic-shape) 860 (text-color atomic-shape) 861 (text-size atomic-shape) 862 (text-face atomic-shape) 863 (text-family atomic-shape) 864 (text-style atomic-shape) 865 (text-weight atomic-shape) 866 (text-underline atomic-shape))] 867 [(flip? atomic-shape) 868 (let ([bitmap (flip-shape atomic-shape)] 869 [flipped? (flip-flipped? atomic-shape)]) 870 (make-flip flipped? 871 (make-ibitmap (ibitmap-raw-bitmap bitmap) 872 (bring-between 873 (+ (ibitmap-angle bitmap) θ) 874 360) 875 (ibitmap-x-scale bitmap) 876 (ibitmap-y-scale bitmap) 877 (make-hash))))])) 878 879;; rotate-point : point angle -> point 880(define (rotate-point p θ) 881 (let-values ([(x y) (rotate-xy (point-x p) (point-y p) θ)]) 882 (make-point x y))) 883 884;; rotate-xy : x,y angle -> x,y 885(define (rotate-xy x y θ) 886 (c->xy (rotate-c (xy->c x y) θ))) 887 888;; bring-between : rational integer -> rational 889;; returns a number that is much like the modulo of 'x' and 'upper-bound', 890;; since modulo only works on integers 891(define (bring-between x upper-bound) 892 (let* ([x-floor (floor x)] 893 [fraction (- x x-floor)]) 894 (+ (modulo x-floor upper-bound) 895 fraction))) 896(module+ test 897 (check-equal? (bring-between 30 180) 30) 898 (check-equal? (bring-between 210 180) 30) 899 (check-equal? (bring-between 30.5 180) 30.5) 900 (check-equal? (bring-between 210.5 180) 30.5) 901 (check-equal? (bring-between 180.5 180) .5) 902 (check-equal? (bring-between 179.9 180) 179.9)) 903 904 905(define/chk (flip-horizontal image) 906 (rotate 90 (flip-vertical (rotate -90 image)))) 907 908(define/chk (flip-vertical image) 909 (let* ([flipped-shape (flip-normalized-shape 910 (send image get-normalized-shape))] 911 [ltrb (normalized-shape-bb flipped-shape)] 912 [ph (send image get-pinhole)]) 913 (make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) flipped-shape) 914 (make-bb (- (ltrb-right ltrb) (ltrb-left ltrb)) 915 (- (ltrb-bottom ltrb) (ltrb-top ltrb)) 916 (- (ltrb-bottom ltrb) (ltrb-top ltrb))) 917 #f 918 (and ph 919 (make-point (+ (point-x ph) (- (ltrb-left ltrb))) 920 (+ (- (point-y ph)) (- (ltrb-top ltrb)))))))) 921 922(define/contract (flip-normalized-shape shape) 923 (-> normalized-shape? normalized-shape?) 924 (cond 925 [(overlay? shape) 926 (let ([top-shape (flip-normalized-shape (overlay-top shape))] 927 [bottom-shape (flip-cn-or-simple-shape (overlay-bottom shape))]) 928 (make-overlay top-shape bottom-shape))] 929 [else 930 (flip-cn-or-simple-shape shape)])) 931 932(define/contract (flip-cn-or-simple-shape shape) 933 (-> cn-or-simple-shape? cn-or-simple-shape?) 934 (cond 935 [(crop? shape) 936 (make-crop (flip-points (crop-points shape)) 937 (flip-normalized-shape (crop-shape shape)))] 938 [else 939 (flip-simple shape)])) 940 941(define/contract (flip-simple simple-shape) 942 (-> simple-shape? simple-shape?) 943 (cond 944 [(line-segment? simple-shape) 945 (make-line-segment (flip-point (line-segment-start simple-shape)) 946 (flip-point (line-segment-end simple-shape)) 947 (line-segment-color simple-shape))] 948 [(curve-segment? simple-shape) 949 (make-curve-segment (flip-point (curve-segment-start simple-shape)) 950 (bring-between (- (curve-segment-s-angle simple-shape)) 360) 951 (curve-segment-s-pull simple-shape) 952 (flip-point (curve-segment-end simple-shape)) 953 (bring-between (- (curve-segment-e-angle simple-shape)) 360) 954 (curve-segment-e-pull simple-shape) 955 (curve-segment-mode simple-shape) 956 (curve-segment-color simple-shape))] 957 [(polygon? simple-shape) 958 (make-polygon (flip-points (polygon-points simple-shape)) 959 (polygon-mode simple-shape) 960 (polygon-color simple-shape))] 961 [else 962 (make-translate (translate-dx simple-shape) 963 (- (translate-dy simple-shape)) 964 (flip-atomic (translate-shape simple-shape)))])) 965 966(define/contract (flip-atomic atomic-shape) 967 (-> np-atomic-shape? np-atomic-shape?) 968 (cond 969 [(ellipse? atomic-shape) 970 (define wedge (ellipse-wedge atomic-shape)) 971 (cond 972 [(and (= (ellipse-width atomic-shape) 973 (ellipse-height atomic-shape)) 974 (not wedge)) 975 atomic-shape] 976 [wedge 977 (define angle (ellipse-angle atomic-shape)) 978 (make-ellipse (ellipse-width atomic-shape) 979 (ellipse-height atomic-shape) 980 (bring-between (- 0 wedge angle) 360) 981 (ellipse-mode atomic-shape) 982 (ellipse-color atomic-shape) 983 (ellipse-wedge atomic-shape))] 984 [else 985 (let ([new-angle (bring-between (- 180 (ellipse-angle atomic-shape)) 180)]) 986 (cond 987 [(< new-angle 90) 988 (make-ellipse (ellipse-width atomic-shape) 989 (ellipse-height atomic-shape) 990 new-angle 991 (ellipse-mode atomic-shape) 992 (ellipse-color atomic-shape) 993 (ellipse-wedge atomic-shape))] 994 [else 995 (make-ellipse (ellipse-height atomic-shape) 996 (ellipse-width atomic-shape) 997 (- new-angle 90) 998 (ellipse-mode atomic-shape) 999 (ellipse-color atomic-shape) 1000 (ellipse-wedge atomic-shape))]))])] 1001 [(text? atomic-shape) 1002 (error 'flip "cannot flip shapes that contain text")] 1003 [(flip? atomic-shape) 1004 (define bitmap (flip-shape atomic-shape)) 1005 (make-flip (not (flip-flipped? atomic-shape)) 1006 (make-ibitmap (ibitmap-raw-bitmap bitmap) 1007 (bring-between (- (ibitmap-angle bitmap)) 360) 1008 (ibitmap-x-scale bitmap) 1009 (ibitmap-y-scale bitmap) 1010 (make-hash)))])) 1011 1012(define (flip-point point) 1013 (cond 1014 [(pulled-point? point) 1015 (make-pulled-point 1016 (pulled-point-lpull point) 1017 (bring-between (- (pulled-point-langle point)) 360) 1018 (pulled-point-x point) 1019 (- (pulled-point-y point)) 1020 (pulled-point-rpull point) 1021 (bring-between (- (pulled-point-rangle point)) 360))] 1022 [else 1023 (make-point (point-x point) (- (point-y point)))])) 1024(define (flip-points points) (map flip-point points)) 1025; 1026; 1027; 1028; ;;;; ;; ;; 1029; ;;;; ;; ;; 1030; ;;;;;;; ;;;;;;; ;;;;; ;;;;; ;;;;;;; ;;;; ;;;;;;; ;;;;;;; ;;; ;;;;; 1031; ;;;;;;;; ;;;;;;;; ;;;;;; ;;;; ;;;;;; ;;;; ;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;; ;;;;;; 1032; ;;;;;;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;; ;;;; ;;;; ;;; ;;;; ;;;; ;; ;;;; 1033; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;; ;;;;;;;; ;;;;;;; ;;;; 1034; ;;;;;;;;; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;; ;;;; ;; ;;;; ;;;;;;; ;;;;; ;;;; 1035; ;;;;;;;; ;;;;;;;; ;;;;;; ;;;; ;;;;;; ;;;; ;;;; ;;; ;;;; ;;;;;;;; ; ;;;; ;;;;;; ;;;;;; 1036; ;;;;;;; ;; ;;;; ;;;;; ;;;; ;;;;; ;;;; ;;;; ;;; ;;;; ;; ;;;; ;;;;;;;; ;;;; ;;;;; 1037; ;;;;;;;; 1038; ;;;;;; 1039; 1040 1041 1042(define/chk (polygon posns-or-pulled-points mode color) 1043 (check-mode/color-combination 'polygon 3 mode color) 1044 (make-a-polygon (for/list ([p (in-list posns-or-pulled-points)]) 1045 (if (posn? p) 1046 (make-point (posn-x p) (posn-y p)) 1047 p)) 1048 mode 1049 color)) 1050 1051(define/chk (rectangle width height mode color) 1052 (check-mode/color-combination 'rectangle 4 mode color) 1053 (make-a-polygon (rectangle-points width height) mode color)) 1054 1055(define/chk (square side-length mode color) 1056 (check-mode/color-combination 'square 3 mode color) 1057 (make-a-polygon (rectangle-points side-length side-length) mode color)) 1058 1059(define/chk (empty-scene width height [color 'white]) 1060 (crop 0 0 width height 1061 (overlay (rectangle width height 'outline (pen "black" 2 'solid 'round 'round)) 1062 (rectangle width height 'solid color)))) 1063 1064(define/chk (rhombus side-length angle mode color) 1065 (check-mode/color-combination 'rhombus 3 mode color) 1066 (let* ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))] 1067 [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))] 1068 [bottom-corner (+ left-corner right-corner)]) 1069 (make-a-polygon (list (make-point 0 0) 1070 (make-point (real-part right-corner) (imag-part right-corner)) 1071 (make-point (real-part bottom-corner) (imag-part bottom-corner)) 1072 (make-point (real-part left-corner) (imag-part left-corner))) 1073 mode 1074 color))) 1075 1076(define (rectangle-points width height [dx 0] [dy 0]) 1077 (list (make-point dx dy) 1078 (make-point (+ dx width) dy) 1079 (make-point (+ dx width) (+ height dy)) 1080 (make-point dx (+ dy height)))) 1081 1082 1083(define/chk (line x1 y1 color) 1084 (let-values ([(shape w h) (line-shape x1 y1 color)]) 1085 (make-image shape 1086 (make-bb w h h) 1087 #f))) 1088 1089(define (line-shape x1 y1 color) 1090 (let ([dx (- (min x1 0))] 1091 [dy (- (min y1 0))] 1092 [w (+ (abs x1) 1)] 1093 [h (+ (abs y1) 1)]) 1094 (values (make-translate 1095 dx dy 1096 (make-line-segment (make-point 0 0) 1097 (make-point x1 y1) 1098 color)) 1099 w h))) 1100 1101(define/chk (add-line image x1 y1 x2 y2 color) 1102 (let* ([dx (abs (min 0 x1 x2))] 1103 [dy (abs (min 0 y1 y2))] 1104 [bottom (max (+ y1 dy) 1105 (+ y2 dy) 1106 (+ dy (get-bottom image)))] 1107 [right (max (+ x1 dx) 1108 (+ x2 dx) 1109 (+ dx (get-right image)))] 1110 [baseline (+ dy (get-baseline image))]) 1111 (make-image (make-translate 1112 dx dy 1113 (make-overlay 1114 (make-line-segment (make-point x1 y1) (make-point x2 y2) color) 1115 (image-shape image))) 1116 (make-bb right bottom baseline) 1117 #f 1118 (send image get-pinhole)))) 1119 1120(define/chk (add-polygon image posns-or-pulled-points mode color) 1121 (check-mode/color-combination 'add-polygon 3 mode color) 1122 (define left (apply min (map pp->x posns-or-pulled-points))) 1123 (define top (apply min (map pp->y posns-or-pulled-points))) 1124 (define poly (polygon posns-or-pulled-points mode color)) 1125 (overlay/xy poly (- left) (- top) image)) 1126 1127(define (pp->x p) 1128 (cond 1129 [(posn? p) (posn-x p)] 1130 [else (pulled-point-x p)])) 1131(define (pp->y p) 1132 (cond 1133 [(posn? p) (posn-y p)] 1134 [else (pulled-point-y p)])) 1135 1136(define/chk (add-solid-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color-only) 1137 (add-a-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 'solid color-only)) 1138 1139(define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color) 1140 (add-a-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 'outline color)) 1141 1142(define (add-a-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 mode color) 1143 (define cs (make-curve-segment (make-point x1 y1) angle1 pull1 1144 (make-point x2 y2) angle2 pull2 1145 mode color)) 1146 (define path (curve-segment->path cs)) 1147 (define rdc (new record-dc%)) 1148 (send rdc set-pen (mode-color->pen 'outline color)) 1149 (send rdc set-brush "black" 'transparent) 1150 (send rdc set-smoothing 'smoothed) 1151 (define-values (path-l path-t path-w path-h) (send rdc get-path-bounding-box path 'stroke)) 1152 (define dx (abs (min 0 path-l))) 1153 (define dy (abs (min 0 path-t))) 1154 (define bottom (max (+ dy path-t path-h) (+ dy (get-bottom image)))) 1155 (define right (max (+ dx path-l path-w) (+ dx (get-right image)))) 1156 (define baseline (+ dy (get-baseline image))) 1157 (make-image (make-translate 1158 dx dy 1159 (make-overlay 1160 cs 1161 (image-shape image))) 1162 (make-bb right bottom baseline) 1163 #f 1164 (send image get-pinhole))) 1165 1166;; this is just so that 'text' objects can be sized. 1167(define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1))) 1168 1169(define/chk (text string font-size color) 1170 (mk-text/lines string font-size color #f 'swiss 'normal 'normal #f)) 1171 1172(define/chk (text/font string font-size color face family style weight underline) 1173 (mk-text/lines string font-size color face family style weight underline)) 1174 1175(define (mk-text/lines str font-size color face family style weight underline) 1176 (let ([lines (string-split str "\n")]) 1177 (cond [(or (null? lines) 1178 (null? (cdr lines))) 1179 (mk-text str font-size color face family style weight underline)] 1180 [else 1181 (apply 1182 above/align 1183 "left" 1184 (map (λ(line) 1185 (mk-text line font-size color face family style weight underline)) 1186 lines))]))) 1187 1188(define (mk-text str font-size color face family style weight underline) 1189 (cond 1190 [(<= (string-length str) 1) 1191 (mk-single-text str font-size color face family style weight underline)] 1192 [else 1193 (let ([letters (string->list str)]) 1194 (beside/internal 1195 'baseline 1196 (mk-single-text (string (car letters)) font-size color face family style weight underline) 1197 (map (λ (letter) 1198 (mk-single-text (string letter) font-size color face family style weight underline)) 1199 (cdr letters))))])) 1200 1201(define (mk-single-text letter font-size color face family style weight underline) 1202 (let ([text (make-text letter 0 1 color font-size face family style weight underline)]) 1203 (let-values ([(w h d a) (send text-sizing-bm get-text-extent letter (text->font text))]) 1204 (make-image (make-translate (/ w 2) (/ h 2) text) 1205 (make-bb w h (- h d)) 1206 #f)))) 1207 1208(define/chk (isosceles-triangle side-length angle mode color) 1209 (check-mode/color-combination 'isosceles-triangle 4 mode color) 1210 (let ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))] 1211 [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))]) 1212 (make-a-polygon (list (make-point 0 0) 1213 (make-point (real-part right-corner) (imag-part right-corner)) 1214 (make-point (real-part left-corner) (imag-part left-corner))) 1215 mode 1216 color))) 1217 1218(define/chk (right-triangle side-length1 side-length2 mode color) 1219 (check-mode/color-combination 'right-triangle 4 mode color) 1220 (make-a-polygon (list (make-point 0 (- side-length2)) 1221 (make-point 0 0) 1222 (make-point side-length1 0)) 1223 mode 1224 color)) 1225 1226(define/chk (triangle side-length mode color) 1227 (check-mode/color-combination 'triangle 3 mode color) 1228 (make-polygon/star side-length 3 mode color values)) 1229 1230; excess : R+ R+ -> R 1231; compute the Euclidean excess 1232; Note: If the excess is 0, then C is 90 deg. 1233; If the excess is negative, then C is obtuse. 1234; If the excess is positive, then C is acuse. 1235(define (excess a b c) 1236 (+ (sqr a) (sqr b) (- (sqr c)))) 1237 1238; polar->posn : R+ R -> (posn R R) 1239; return a position with x and y coordinates 1240(define (polar->posn radius angle) 1241 (make-posn (* radius (cos angle)) 1242 (* radius (sin angle)))) 1243 1244; cos-rel : R R R -> R+ 1245; return c^2 = a^2 + b^2 - 2ab cos(C) 1246(define (cos-rel a b C) 1247 (+ (sqr a) (sqr b) (* -2 a b (cos C)))) 1248 1249; sin-rel : R R R -> R 1250; return the side b 1251(define (sin-rel A a B) 1252 (/ (* a (sin B)) (sin A))) 1253 1254; last-angle : R R -> R 1255; return pi-(A+B) 1256(define (last-angle A B) 1257 (- pi A B)) 1258 1259(define (radians degree) 1260 (* (/ degree 180.0) pi)) 1261 1262 1263(define (triangle/sss side-a side-b side-c mode color) 1264 (define (triangle-vertices/sss a b c) 1265 (let ([A (acos (/ (excess b c a) (* 2 b c)))]) 1266 (list (make-posn 0 0) 1267 (make-posn c 0) 1268 (polar->posn b A)))) 1269 (check-dependencies 'triangle/sss 1270 (and (>= (+ side-a side-b) side-c) 1271 (>= (+ side-a side-c) side-b) 1272 (>= (+ side-b side-c) side-a)) 1273 "the given side lengths will not form a triangle ~a, ~a, and, ~a." 1274 side-a side-b side-c) 1275 (polygon (triangle-vertices/sss side-a side-b side-c) mode color)) 1276 1277(define/chk (triangle/ass angle-a side-b side-c mode color) 1278 (define (triangle-vertices/ass A b c) 1279 (list (make-posn 0 0) (make-posn c 0) (polar->posn b A))) 1280 (polygon (triangle-vertices/ass (radians angle-a) side-b side-c) mode color)) 1281 1282(define/chk (triangle/sas side-a angle-b side-c mode color) 1283 (define (triangle-vertices/sas a B c) 1284 (let ([b^2 (cos-rel a c B)]) 1285 (check-dependencies 'triangle/sas 1286 "the given side, angle, and, side will not form a triangle ~a, ~a, and, ~a." 1287 side-a angle-b side-c) 1288 (let* ([b (sqrt b^2)] 1289 [A (acos (/ (excess b c a) (* 2 b c)))]) 1290 (list (make-posn 0 0) (make-posn c 0) (polar->posn b A))))) 1291 (polygon (triangle-vertices/sas side-a (radians angle-b) side-c) mode color)) 1292(define/chk (triangle/ssa side-a side-b angle-c mode color) 1293 (define (triangle-vertices/ssa a b C) 1294 (let ([c^2 (cos-rel a b C)]) 1295 (check-dependencies 'triangle/ssa 1296 (positive? c^2) 1297 "the given side, side, and, angle will not form a triangle ~a, ~a, and, ~a." 1298 side-a side-b angle-c) 1299 (let*([c (sqrt c^2)] 1300 [A (acos (/ (excess b c a) (* 2 b c)))]) 1301 (list (make-posn 0 0) 1302 (make-posn c 0) 1303 (polar->posn b A))))) 1304 (polygon (triangle-vertices/ssa side-a side-b (radians angle-c)) mode color)) 1305 1306(define/chk (triangle/aas angle-a angle-b side-c mode color) 1307 (define (triangle-vertices/aas A B c) 1308 (let* ([C (last-angle A B)] 1309 [b (sin-rel C c B)]) 1310 (list (make-posn 0 0) (make-posn c 0) (polar->posn b A)))) 1311 (polygon (triangle-vertices/aas (radians angle-a) (radians angle-b) side-c) mode color)) 1312 1313(define/chk (triangle/asa angle-a side-b angle-c mode color) 1314 (define (triangle-vertices/asa A b C) 1315 (let* ([B (last-angle A C)] 1316 [c (sin-rel B b C)]) 1317 (list (make-posn 0 0) (make-posn c 0) (polar->posn b A)))) 1318 (polygon (triangle-vertices/asa (radians angle-a) side-b (radians angle-c)) mode color)) 1319 1320(define/chk (triangle/saa side-a angle-b angle-c mode color) 1321 (define (triangle-vertices/saa a B C) 1322 (let* ([A (last-angle B C)] 1323 [b (sin-rel A a B)] 1324 [c (sin-rel A a C)]) 1325 (list (make-posn 0 0) 1326 (make-posn c 0) 1327 (polar->posn b A)))) 1328 (polygon (triangle-vertices/saa side-a (radians angle-b) (radians angle-c)) mode color)) 1329 1330(define/chk (regular-polygon side-length side-count mode color) 1331 (check-mode/color-combination 'regular-polygon 4 mode color) 1332 (make-polygon/star side-length side-count mode color values)) 1333 1334(define/chk (pulled-regular-polygon side-length side-count pull angle mode color) 1335 (check-mode/color-combination 'regular-polygon 4 mode color) 1336 (make-a-polygon (regular-polygon-points side-length side-count pull angle) 1337 mode color)) 1338 1339(define/chk (star-polygon side-length side-count step-count mode color) 1340 (check-mode/color-combination 'star-polygon 5 mode color) 1341 (check-arg 'star-polygon 1342 (step-count . < . side-count) 1343 (format "number that is smaller than the side-count (~a)" side-count) 1344 3 1345 step-count) 1346 (check-arg 'star-polygon 1347 (= 1 (gcd side-count step-count)) 1348 (format "number that is relatively prime to the side-count (~a)" side-count) 1349 3 1350 step-count) 1351 (make-polygon/star side-length side-count mode color (λ (l) (swizzle l step-count)))) 1352 1353(define/chk (star side-length mode color) 1354 (check-mode/color-combination 'star 3 mode color) 1355 (make-polygon/star side-length 5 mode color (λ (l) (swizzle l 2)))) 1356 1357(define (make-polygon/star side-length side-count mode color adjust) 1358 (make-a-polygon (adjust (regular-polygon-points side-length side-count 0 0)) 1359 mode color)) 1360 1361(define/chk (radial-star point-count radius1 radius2 mode color) 1362 (make-a-polygon (star-points radius1 radius2 point-count) mode color)) 1363 1364(define (star-points in-small-rad in-large-rad points) 1365 (let* ([small-rad (- in-small-rad 1)] 1366 [large-rad (- in-large-rad 1)] 1367 [roff (floor (/ large-rad 2))]) 1368 (let loop ([i points]) 1369 (cond 1370 [(zero? i) '()] 1371 [else 1372 (let* ([this-p (- i 1)] 1373 [theta1 (* 2 pi (/ this-p points))] 1374 [theta2 (* 2 pi (/ (- this-p 1/2) points))]) 1375 (let-values ([(x1 y1) (find-xy small-rad theta1)] 1376 [(x2 y2) (find-xy large-rad theta2)]) 1377 (let ([p1 (make-point (+ large-rad x1) 1378 (+ large-rad y1))] 1379 [p2 (make-point (+ large-rad x2) 1380 (+ large-rad y2))]) 1381 (list* p1 p2 (loop (- i 1))))))])))) 1382 1383(define (find-xy radius theta) 1384 (values (* radius (cos theta)) 1385 (* radius (sin theta)))) 1386 1387(define (make-a-polygon points mode color) 1388 (let* ([poly (make-polygon points mode color)] 1389 [ltrb (simple-bb poly)] 1390 [l (ltrb-left ltrb)] 1391 [t (ltrb-top ltrb)] 1392 [r (ltrb-right ltrb)] 1393 [b (ltrb-bottom ltrb)]) 1394 (make-image (make-translate (- l) (- t) poly) 1395 (make-bb (- r l) (- b t) (- b t)) 1396 #f))) 1397(define (gcd a b) 1398 (cond 1399 [(zero? b) a] 1400 [else (gcd b (modulo a b))])) 1401 1402 1403 1404;; swizzle : (listof X)[odd-length] -> (listof X) 1405;; returns a list with the same elements, 1406;; but reordered according to the step. Eg, if the step 1407;; is 2, we get the even elements and then the odd ones. 1408(define (swizzle l step) 1409 (let ([v (list->vector l)]) 1410 (let loop ([i 0]) 1411 (cond 1412 [(= i (vector-length v)) '()] 1413 [else 1414 (cons (vector-ref v (modulo (* i step) (vector-length v))) 1415 (loop (+ i 1)))])))) 1416 1417;; regular-polygon-points : number number -> (listof point) 1418(define (regular-polygon-points side-length side-count pull angle) 1419 (let loop ([p (make-rectangular 0 0)] 1420 [i 0]) 1421 (cond 1422 [(= i side-count) '()] 1423 [else (cons (build-pulled-point pull angle (real-part p) (imag-part p) pull (- angle)) 1424 (loop (+ p (make-polar side-length 1425 (* -1 2pi (/ i side-count)))) 1426 (+ i 1)))]))) 1427 1428(define/chk (ellipse width height mode color) 1429 (check-mode/color-combination 'ellipse 4 mode color) 1430 (cond 1431 [(or (zero? width) (zero? height)) 1432 (make-a-polygon (rectangle-points width height) mode color)] 1433 [else 1434 (make-image (make-translate (/ width 2) (/ height 2) 1435 (make-ellipse width height 1436 0 1437 mode 1438 color 1439 #f)) 1440 (make-bb width height height) 1441 #f)])) 1442 1443(define/chk (wedge non-zero-radius angle-between-0-and-360 mode color) 1444 (check-mode/color-combination 'ellipse 4 mode color) 1445 (define width (* 2 non-zero-radius)) 1446 (define the-wedge (make-ellipse width width 0 mode color angle-between-0-and-360)) 1447 (define-values (l t r b) (np-atomic-bb the-wedge)) 1448 (define w (- r l)) 1449 (define h (- b t)) 1450 (make-image (make-translate (- l) (- t) the-wedge) 1451 (make-bb w h h) 1452 #f)) 1453 1454(define/chk (circle radius mode color) 1455 (check-mode/color-combination 'circle 3 mode color) 1456 (cond 1457 [(zero? radius) 1458 (make-a-polygon (rectangle-points 0 0) mode color)] 1459 [else 1460 (define w/h (* 2 radius)) 1461 (make-image (make-translate radius radius (make-ellipse w/h w/h 0 mode color #f)) 1462 (make-bb w/h w/h w/h) 1463 #f)])) 1464 1465(define empty-image (rectangle 0 0 'solid 'black)) 1466 1467(define/chk (image-width image) (bb-select/round/exact bb-right image)) 1468(define/chk (image-height image) (bb-select/round/exact bb-bottom image)) 1469(define/chk (image-baseline image) (bb-select/round/exact bb-baseline image)) 1470(define (bb-select/round/exact select image) (inexact->exact (round (select (send image get-bb))))) 1471 1472(define-syntax (bitmap stx) 1473 (syntax-case stx () 1474 [(_ arg) 1475 (let* ([arg (syntax->datum #'arg)] 1476 [path/lst 1477 (cond 1478 [(and (pair? arg) 1479 (eq? (car arg) 'planet)) 1480 (raise-syntax-error 'bitmap "planet paths not yet supported" stx)] 1481 [(symbol? arg) 1482 (define pieces (regexp-split #rx"/" (symbol->string arg))) 1483 (cond 1484 [(or (null? pieces) (null? (cdr pieces))) 1485 (raise-syntax-error 'bitmap "expected a path with a / in it" stx)] 1486 [else 1487 (define fn (last pieces)) 1488 (define colls (reverse (cdr (reverse pieces)))) 1489 (define candidate 1490 (apply collection-file-path fn colls 1491 #:fail 1492 (λ (msg) (raise-syntax-error 'bitmap msg stx)))) 1493 (unless (file-exists? candidate) 1494 (raise-syntax-error 'bitmap 1495 (format "could not find ~s, expected it to be in ~a" 1496 arg candidate) 1497 stx)) 1498 (cons fn colls)])] 1499 [(string? arg) 1500 (path->complete-path 1501 arg 1502 (or (current-load-relative-directory) 1503 (current-directory)))] 1504 [else (raise-syntax-error 1505 'bitmap 1506 (string-append 1507 "expected the argument to specify a local path (via a string)" 1508 " or a module path (e.g. `icons/b-run.png')") 1509 stx)])]) 1510 #`(bitmap/proc '#,path/lst))])) 1511 1512(define (bitmap/proc arg) 1513 (define pth (if (path? arg) 1514 arg 1515 (apply collection-file-path arg 1516 #:fail 1517 (λ (msg) (error 'bitmap msg))))) 1518 (when (and (path? pth) 1519 (not (file-exists? pth))) 1520 (error 'bitmap "could not find the file ~a" (path->string pth))) 1521 ;; the rotate does a coercion to a 2htdp/image image 1522 (rotate 0 (make-object image-snip% (make-object bitmap% pth 'unknown/alpha)))) 1523 1524(define/chk (bitmap/url string) 1525 ;; the rotate does a coercion to a 2htdp/image image 1526 (rotate 1527 0 1528 (call/input-url (string->url string) 1529 (lambda (url) (get-pure-port url #:redirections 20)) 1530 (λ (port) 1531 (make-object bitmap% port 'unknown/alpha #f #t))))) 1532 1533(define/chk (bitmap/file filename) 1534 (unless (file-exists? filename) 1535 (error 'bitmap/file 1536 "could not find the file ~a" 1537 filename)) 1538 (rotate 1539 0 1540 (read-bitmap filename))) 1541 1542(define/chk (image->color-list image) 1543 (define w (image-width image)) 1544 (define h (image-height image)) 1545 (cond 1546 [(or (= w 0) (= h 0)) '()] 1547 [else 1548 (define bm (make-bitmap w h)) 1549 (define bdc (make-object bitmap-dc% bm)) 1550 (define c (make-object color%)) 1551 (define bytes (make-bytes (* w h 4))) 1552 (send bdc erase) 1553 (render-image image bdc 0 0) 1554 (send bdc get-argb-pixels 0 0 w h bytes) 1555 (for/list ([i (in-range 0 (* w h 4) 4)]) 1556 (color (bytes-ref bytes (+ i 1)) 1557 (bytes-ref bytes (+ i 2)) 1558 (bytes-ref bytes (+ i 3)) 1559 (bytes-ref bytes i)))])) 1560 1561(define/chk (color-list->bitmap color-list width height) 1562 (check-dependencies 1563 'color-list->bitmap 1564 (= (* width height) (length color-list)) 1565 (string-append 1566 "the length of the color list to match the product of the width and the height," 1567 " but the list has ~a elements and the width and height are ~a and ~a respectively") 1568 (length color-list) width height) 1569 (cond 1570 [(or (zero? width) (zero? height)) 1571 (rectangle width height "solid" "black")] 1572 [else 1573 (define bmp (make-bitmap width height)) 1574 (define bytes (make-bytes (* width height 4) 0)) 1575 (define o (make-object color%)) 1576 (for ([c (in-list color-list)] 1577 [i (in-naturals)]) 1578 (define j (* i 4)) 1579 (cond 1580 [(color? c) 1581 (bytes-set! bytes j (color-alpha c)) 1582 (bytes-set! bytes (+ j 1) (color-red c)) 1583 (bytes-set! bytes (+ j 2) (color-green c)) 1584 (bytes-set! bytes (+ j 3) (color-blue c))] 1585 [else 1586 (define str (if (string? c) c (symbol->string c))) 1587 (define clr (or (string->color-object/f str) 1588 (send the-color-database find-color "black"))) 1589 (bytes-set! bytes j 255) ;; this should probably (send clr alpha) when that's possible 1590 (bytes-set! bytes (+ j 1) (send clr red)) 1591 (bytes-set! bytes (+ j 2) (send clr green)) 1592 (bytes-set! bytes (+ j 3) (send clr blue))])) 1593 (send bmp set-argb-pixels 0 0 width height bytes) 1594 (bitmap->image bmp)])) 1595 1596(define build-color/make-color 1597 (let ([orig-make-color make-color]) 1598 (define/chk make-color 1599 (case-lambda 1600 [(int0-255-1 int0-255-2 int0-255-3) 1601 (orig-make-color int0-255-1 int0-255-2 int0-255-3)] 1602 [(int0-255-1 int0-255-2 int0-255-3 int0-255-4) 1603 (orig-make-color int0-255-1 int0-255-2 int0-255-3 int0-255-4)])) 1604 make-color)) 1605 1606(define/chk (pinhole-x image) (let ([ph (send image get-pinhole)]) (and ph (point-x ph)))) 1607(define/chk (pinhole-y image) (let ([ph (send image get-pinhole)]) (and ph (point-y ph)))) 1608(define/chk (put-pinhole x1 y1 image) 1609 (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x1 y1))) 1610(define/chk (center-pinhole image) 1611 (let ([bb (send image get-bb)]) 1612 (make-image (image-shape image) 1613 (image-bb image) 1614 (image-normalized? image) 1615 (make-point (/ (bb-right bb) 2) 1616 (/ (bb-baseline bb) 2))))) 1617(define/chk (clear-pinhole image) 1618 (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) 1619 1620(define build-color/color 1621 (let ([orig-make-color make-color]) 1622 (define/chk color 1623 (case-lambda 1624 [(int0-255-1 int0-255-2 int0-255-3) 1625 (orig-make-color int0-255-1 int0-255-2 int0-255-3)] 1626 [(int0-255-1 int0-255-2 int0-255-3 int0-255-4) 1627 (orig-make-color int0-255-1 int0-255-2 int0-255-3 int0-255-4)])) 1628 color)) 1629 1630(define build-pulled-point/pulled-point 1631 (let () 1632 (define/chk (pulled-point pull1 angle1 x y pull2 angle2) 1633 (build-pulled-point pull1 angle1 x y pull2 angle2)) 1634 pulled-point)) 1635 1636(define build-pulled-point/make-pulled-point 1637 (let () 1638 (define/chk (make-pulled-point pull1 angle1 x y pull2 angle2) 1639 (build-pulled-point pull1 angle1 x y pull2 angle2)) 1640 make-pulled-point)) 1641 1642(define build-pen/make-pen 1643 (let ([orig-make-pen make-pen]) 1644 (define/chk (make-pen color int-0-255 pen-style pen-cap pen-join) 1645 (orig-make-pen color int-0-255 pen-style pen-cap pen-join)) 1646 make-pen)) 1647 1648(define build-pen/pen 1649 (let ([orig-make-pen make-pen]) 1650 (define/chk (pen color int-0-255 pen-style pen-cap pen-join) 1651 (orig-make-pen color int-0-255 pen-style pen-cap pen-join)) 1652 pen)) 1653 1654(define/chk freeze 1655 (case-lambda 1656 [(image) (freeze/internal 0 0 (image-width image) (image-height image) image)] 1657 [(width height image) (freeze/internal 0 0 width height image)] 1658 [(x y width height image) (freeze/internal x y width height image)])) 1659 1660(define (freeze/internal x y w h image) 1661 (cond 1662 [(or (zero? w) (zero? h)) 1663 ;; ensures that we never return an image with an embedded `text` in 1664 ;; it which, in turn, guarantees that we can flip the result 1665 (rectangle w h 'solid 'black)] 1666 [else 1667 (define bm (make-bitmap w h)) 1668 (define bdc (make-object bitmap-dc% bm)) 1669 (render-image image bdc (- x) (- y)) 1670 (send bdc set-bitmap #f) 1671 (to-img bm)])) 1672 1673(provide overlay 1674 overlay/align 1675 overlay/offset 1676 overlay/align/offset 1677 overlay/xy 1678 1679 underlay 1680 underlay/align 1681 underlay/align/offset 1682 underlay/offset 1683 underlay/xy 1684 1685 beside 1686 beside/align 1687 above 1688 above/align 1689 1690 rotate 1691 crop 1692 crop/align 1693 flip-vertical 1694 flip-horizontal 1695 frame 1696 color-frame 1697 1698 place-image 1699 place-image/align 1700 place-images 1701 place-images/align 1702 put-image 1703 1704 save-image 1705 save-svg-image 1706 bring-between 1707 1708 1709 scale 1710 scale/xy 1711 1712 image-width 1713 image-height 1714 image-baseline 1715 1716 circle 1717 ellipse 1718 wedge 1719 rectangle 1720 empty-scene 1721 square 1722 rhombus 1723 empty-image 1724 1725 polygon 1726 regular-polygon 1727 pulled-regular-polygon 1728 triangle 1729 triangle/sss 1730 triangle/ssa 1731 triangle/sas 1732 triangle/ass 1733 triangle/aas 1734 triangle/asa 1735 triangle/saa 1736 1737 isosceles-triangle 1738 right-triangle 1739 star 1740 star-polygon 1741 radial-star 1742 1743 line 1744 add-line 1745 add-polygon 1746 add-curve 1747 add-solid-curve 1748 scene+line 1749 scene+polygon 1750 scene+curve 1751 text 1752 text/font 1753 image->color-list 1754 color-list->bitmap 1755 1756 bitmap 1757 bitmap/url 1758 bitmap/file 1759 1760 swizzle 1761 1762 rotate-xy 1763 1764 put-pinhole 1765 pinhole-x 1766 pinhole-y 1767 clear-pinhole 1768 center-pinhole 1769 overlay/pinhole 1770 underlay/pinhole 1771 1772 build-color/make-color 1773 build-color/color 1774 build-pen/make-pen 1775 build-pen/pen 1776 build-pulled-point/make-pulled-point 1777 build-pulled-point/pulled-point 1778 1779 freeze 1780 1781 render-image) 1782 1783(provide/contract 1784 [np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))] 1785 [center-point (-> np-atomic-shape? number?)]) 1786
