1#lang racket/base 2(require racket/draw 3 racket/gui/dynamic 4 racket/serialize 5 (except-in racket/list drop) 6 racket/contract/base 7 racket/class 8 racket/generic 9 (prefix-in file: file/convertible) 10 racket/promise 11 (for-syntax racket/base racket/syntax 12 racket/struct-info 13 syntax/transformer)) 14 15(provide dc-for-text-size 16 convert-bounds-padding 17 show-pict 18 caps-text current-expected-text-scale 19 dc 20 linewidth 21 linestyle 22 23 draw-pict 24 make-pict-drawer 25 26 (contract-out 27 [text (->* (string?) 28 (text-style/c 29 (and/c (between/c 1 1024) integer?) 30 number?) 31 pict?)]) 32 33 text-style/c 34 35 (struct-out pict) 36 (struct-out child) 37 38 black-and-white 39 40 lt-find 41 lc-find 42 lb-find 43 ltl-find 44 lbl-find 45 ct-find 46 cc-find 47 cb-find 48 ctl-find 49 cbl-find 50 rt-find 51 rc-find 52 rb-find 53 rtl-find 54 rbl-find 55 56 find-lt ; (left & top) ; pict pict-path -> dx dy 57 find-lc ; (left & vertical center) 58 find-lb ; (left & bottom) 59 find-ltl ; (left and top baseline) 60 find-lbl ; (left and bottom baseline) 61 find-ct ; (horizontal center & top) 62 find-cc 63 find-cb 64 find-ctl 65 find-cbl 66 find-rt 67 find-rc 68 find-rb 69 find-rtl 70 find-rbl 71 72 launder ; pict -> pict 73 74 blank ; -> pict 75 ;; w h -> pict 76 ;; w h d -> pict 77 78 clip-descent ; pict -> pict 79 clip-ascent ; pict -> pict 80 lift-above-baseline ; pict -> pict 81 drop-below-ascent ; pict -> pict 82 baseless ; pict -> pict 83 inset ; pict i -> pict 84 ; pict hi vi -> pict 85 ; pict l t r b -> pict 86 refocus ; pict pict -> pict 87 panorama ; pict -> pict 88 89 use-last ; pict pict -> pict 90 use-last* ; pict pict -> pict 91 92 hline ; w h -> pict 93 dash-hline ; w h seg-length -> pict ; default seg-length is 5 94 vline ; w h -> pict 95 dash-vline ; w h seg-length -> pict ; default seg-length is 5 96 97 frame ; pict -> pict 98 dash-frame ; pict seg-length -> pict ; default seg-length is 5 99 oval ; pict -> pict 100 oval/radius ; pict r -> pict ; r is radius of corners 101 102 big-circle ; diameter -> pict 103 104 thick ; pict -> pict 105 thin ; pict -> pict 106 107 ghost ; pict -> pict 108 109 record ; pict pict ... -> pict 110 111 vl-append ; d pict ... -> pict ; d units between each picture 112 vc-append 113 vr-append 114 ht-append 115 hc-append 116 hb-append 117 htl-append ; align bottoms of ascents 118 hbl-append ; align tops of descents (normal text alignment) 119 120 lt-superimpose ; pict ... -> pict 121 lb-superimpose 122 lc-superimpose 123 ltl-superimpose 124 lbl-superimpose 125 rt-superimpose 126 rb-superimpose 127 rc-superimpose 128 rtl-superimpose 129 rbl-superimpose 130 ct-superimpose 131 cb-superimpose 132 cc-superimpose 133 ctl-superimpose 134 cbl-superimpose 135 136 table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict 137 138 colorize ; pict color-string -> pict 139 140 picture ; w h command-list -> pict 141 picture* ; w h a d command-list -> pict 142 143 cons-picture ; pict command-list -> pict 144 cons-picture* ; pict command-list -> pict 145 146 place-over 147 place-under 148 pin-over 149 pin-under 150 151 prop:pict-convertible prop:pict-convertible? pict-convertible? pict-convert 152 pict-convertible-ref 153 pict-path-element=? 154 pict-path? 155 pict-deserialize-info) 156 157;; ; ---------------------------------------- 158 159(define-values (prop:pict-convertible -pict-convertible? pict-convertible-ref) 160 (make-struct-type-property 'pict-convertible)) 161 162(define-values (prop:pict-convertible? pict-convertible?? pict-convertible?-ref) 163 (make-struct-type-property 'pict-convertible?)) 164 165(begin-for-syntax 166 (struct pict-wrapper () 167 #:property prop:set!-transformer 168 (set!-transformer-procedure 169 (make-variable-like-transformer #'in:pict)) 170 #:property prop:struct-info 171 (lambda (_) 172 (list #'struct:pict 173 #'make-pict 174 #'pict? 175 (reverse (list #'pict-draw 176 #'pict-width 177 #'pict-height 178 #'pict-ascent 179 #'pict-descent 180 #'pict-children 181 #'pict-panbox 182 #'pict-last)) 183 (list #f 184 #f 185 #f 186 #f 187 #f 188 #f 189 #f 190 #f) 191 #t)))) 192 193(define-syntax pict (pict-wrapper)) 194 195(define-syntax (define-pict-wrap stx) 196 (syntax-case stx () 197 [(_ name) 198 (with-syntax* ([f (format-id stx "~a-~a" 'pict #'name)] 199 [a (format-id stx "in:~a-~a" 'pict #'name)]) 200 #`(define (f p) 201 (a (if (pict? p) 202 p 203 (pict-convert/who p 'f)))))])) 204 205(define-pict-wrap draw) 206(define-pict-wrap width) 207(define-pict-wrap height) 208(define-pict-wrap ascent) 209(define-pict-wrap descent) 210(define-pict-wrap children) 211(define-pict-wrap panbox) 212(define-pict-wrap last) 213 214(define-struct in:pict (draw ; drawing instructions 215 width ; total width 216 height ; total height >= ascent + desecnt 217 ascent ; portion of height above top baseline 218 descent ; portion of height below bottom baseline 219 children ; list of child records 220 panbox ; panorama box, computed on demand 221 last) ; a descendent for the bottom-right 222 #:reflection-name 'pict 223 #:mutable 224 #:property prop:pict-convertible (λ (v) v) 225 #:property file:prop:convertible (lambda (v mode default) 226 (convert-pict v mode default)) 227 #:property prop:serializable (make-serialize-info 228 (lambda (p) 229 (convert-pict-to-vector p)) 230 #'pict-deserialize-info 231 #f 232 (or (current-load-relative-directory) 233 (current-directory)))) 234 235(define make-pict make-in:pict) 236(define pict? in:pict?) 237(define struct:pict struct:in:pict) 238 239(define-syntax (define-pict-setter stx) 240 (syntax-case stx () 241 [(_ name) 242 (with-syntax ([f (format-id stx "~a-~a!" 'set-pict #'name)] 243 [a (format-id stx "~a-~a!" 'set-in:pict #'name)]) 244 #'(define f a))])) 245 246(define-pict-setter draw) 247(define-pict-setter width) 248(define-pict-setter height) 249(define-pict-setter ascent) 250(define-pict-setter descent) 251(define-pict-setter children) 252(define-pict-setter panbox) 253(define-pict-setter last) 254 255(define-struct child (pict dx dy sx sy sxy syx)) 256(define-struct bbox (x1 y1 x2 y2 ay dy)) 257 258(define (pict-convertible? x) 259 (or (pict? x) 260 (and (-pict-convertible? x) 261 (if (pict-convertible?? x) 262 ((pict-convertible?-ref x) x) 263 #t)))) 264 265(define (pict-convert v) (pict-convert/who v 'pict-convert)) 266(define (pict-convert/who v who) 267 (cond [(pict? v) v] 268 [(not (pict-convertible? v)) 269 (raise-type-error who "pict-convertible" v)] 270 [else 271 (define converted ((pict-convertible-ref v) v)) 272 (converted-pict 273 (pict-draw converted) 274 (pict-width converted) 275 (pict-height converted) 276 (pict-ascent converted) 277 (pict-descent converted) 278 (pict-children converted) 279 (pict-panbox converted) 280 (pict-last converted) 281 v)])) 282 283(struct converted-pict pict (parent)) 284 285(define (pict-path-element=? a b) 286 (or (eq? a b) 287 (if (converted-pict? a) 288 (if (converted-pict? b) 289 (eq? (converted-pict-parent a) (converted-pict-parent b)) 290 (eq? (converted-pict-parent a) b)) 291 (if (converted-pict? b) 292 (eq? (converted-pict-parent b) a) 293 #f)))) 294 295(define (pict-path? p) 296 (or (pict-convertible? p) 297 (and (pair? p) 298 (list? p) 299 (andmap pict-convertible? p)))) 300 301;; ---------------------------------------- 302 303(define family/c 304 (or/c 'base 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system)) 305 306(define text-style/c 307 (flat-rec-contract 308 text-style/c 309 (or/c null? 310 (is-a?/c font%) 311 family/c 312 string? ;; could be more specific, I guess. 313 (cons/c string? family/c) 314 (cons/c (or/c 'bold 'italic 'superscript 'subscript 315 'large-script 316 'combine 'no-combine 'caps 317 'outline 'aligned 'unaligned 318 (is-a?/c color%)) 319 text-style/c)))) 320 321 322(define default-seg 5) 323(define recordseplinespace 4) 324 325(define blank 326 (case-lambda 327 [() (blank 0 0 0)] 328 [(s) (blank s s)] 329 [(w h) (blank w h 0)] 330 [(w a d) (make-pict `(picture ,w ,(+ a d)) w (+ a d) a d null #f #f)] 331 [(w h a d) (make-pict `(picture ,w ,h) w h a d null #f #f)])) 332 333(define (extend-pict box dx dy dw da dd draw) 334 (let ([w (pict-width box)] 335 [h (pict-height box)] 336 [d (pict-descent box)] 337 [a (pict-ascent box)]) 338 (make-pict (if draw draw (pict-draw box)) 339 (+ w dw) (+ h da dd) 340 (max 0 (+ a da)) (max 0 (+ d dd)) 341 (list (make-child box dx dy 1 1 0 0)) 342 #f 343 (pict-last box)))) 344 345(define (transform dx dy tdx tdy tsx tsy tsxy tsyx) 346 (values (+ (* tsx dx) (* tsxy dy) tdx) 347 (+ (* tsy dy) (* tsyx dx) tdy))) 348 349(define (single-pict-offset pict subbox dx dy) 350 (let floop ([box pict] 351 [found values] 352 [not-found (lambda () (error 'find-XX 353 "sub-pict: ~a not found in: ~a" 354 subbox pict))]) 355 (if (pict-path-element=? subbox box) 356 (found dx dy) 357 (let loop ([c (pict-children box)]) 358 (if (null? c) 359 (not-found) 360 (floop (child-pict (car c)) 361 (lambda (dx dy) 362 (let ([c (car c)]) 363 (let-values ([(dx dy) 364 (transform 365 dx dy 366 (child-dx c) (child-dy c) 367 (child-sx c) (child-sy c) 368 (child-sxy c) (child-syx c))]) 369 (found dx dy)))) 370 (lambda () 371 (loop (cdr c))))))))) 372 373(define (find-lbx pict subbox-path dx dy) 374 (if (pict-convertible? subbox-path) 375 (single-pict-offset pict subbox-path dx dy) 376 (let loop ([l (cons pict subbox-path)]) 377 (if (null? (cdr l)) 378 (values dx dy) 379 (let-values ([(dx dy) (loop (cdr l))]) 380 (single-pict-offset (car l) (cadr l) dx dy)))))) 381 382(define-values (find-lt 383 find-lc 384 find-lb 385 find-ltl 386 find-lbl 387 find-ct 388 find-cc 389 find-cb 390 find-ctl 391 find-cbl 392 find-rt 393 find-rc 394 find-rb 395 find-rtl 396 find-rbl) 397 (let ([lb (lambda (x sx w d a) x)] 398 [c (lambda (x sx w d a) (+ x (* sx (/ w 2))))] 399 [rt (lambda (x sx w d a) (+ x (* sx w)))] 400 [tline (lambda (x sx w d a) (+ x (* sx (- w a))))] 401 [bline (lambda (x sx w d a) (+ x (* sx d)))] 402 [find (lambda (get-x get-y) 403 (lambda (pict pict-path) 404 (let ([p (let loop ([path pict-path]) 405 (cond 406 [(pict? path) path] 407 [(pict-convertible? path) (pict-convert path)] 408 [(null? (cdr path)) (loop (car path))] 409 [else (loop (cdr path))]))]) 410 (let ([w (pict-width p)] 411 [h (pict-height p)] 412 [d (pict-descent p)] 413 [a (pict-ascent p)]) 414 (find-lbx pict pict-path 415 (get-x 0 1 w 0 0) 416 (get-y 0 1 h d a))))))]) 417 (values (find lb rt) 418 (find lb c) 419 (find lb lb) 420 (find lb tline) 421 (find lb bline) 422 (find c rt) 423 (find c c) 424 (find c lb) 425 (find c tline) 426 (find c bline) 427 (find rt rt) 428 (find rt c) 429 (find rt lb) 430 (find rt tline) 431 (find rt bline)))) 432 433(define-values (lt-find 434 lc-find 435 lb-find 436 ltl-find 437 lbl-find 438 ct-find 439 cc-find 440 cb-find 441 ctl-find 442 cbl-find 443 rt-find 444 rc-find 445 rb-find 446 rtl-find 447 rbl-find) 448 (let ([flip (lambda (orig) 449 (lambda (pict pict-path) 450 (let-values ([(x y) (orig pict pict-path)]) 451 (values x (- (pict-height pict) y)))))]) 452 (values (flip find-lt) 453 (flip find-lc) 454 (flip find-lb) 455 (flip find-ltl) 456 (flip find-lbl) 457 (flip find-ct) 458 (flip find-cc) 459 (flip find-cb) 460 (flip find-ctl) 461 (flip find-cbl) 462 (flip find-rt) 463 (flip find-rc) 464 (flip find-rb) 465 (flip find-rtl) 466 (flip find-rbl)))) 467 468(define (launder box*) 469 ;; we might be given a pict-convertable 470 ;; but set-pict-foo! isn't defined on those 471 (define box 472 (if (pict? box*) 473 box* 474 (pict-convert box*))) 475 (unless (pict-panbox box) 476 (panorama-box! box)) 477 (let ([b (extend-pict box 0 0 0 0 0 #f)]) 478 (set-pict-children! b null) 479 (set-pict-panbox! b (pict-panbox box)) 480 ;; After laundering, we can't find the last-pos box. 481 ;; So create a new last-position box to preserve the 482 ;; original shape: 483 (let ([l (pict-last box)]) 484 (set-pict-last! box #f) ; preserve invariants 485 (cond 486 [(not l) b] 487 [else 488 (let-values ([(x y) (lt-find box l)] 489 [(l) (let loop ([l l]) 490 (if (pair? l) 491 (if (null? (cdr l)) 492 (car l) 493 (loop (cdr l))) 494 l))]) 495 (let ([b2 (blank (pict-width l) (pict-height l) 496 (pict-ascent l) (pict-descent l))]) 497 (use-last/unchecked 498 (pin-over b x y b2) 499 b2)))])))) 500 501(define (lift-above-baseline p n) 502 (let* ([dh (- (max 0 (- n (pict-descent p))))] 503 [do-a? (= (pict-height p) 504 (+ (pict-ascent p) (pict-descent p)))] 505 [h2 (+ dh (pict-height p))] 506 [d2 (max 0 (- (pict-descent p) n))]) 507 (make-pict (pict-draw p) 508 (pict-width p) h2 509 (if do-a? 510 (- h2 d2) 511 (pict-ascent p)) 512 d2 513 (map (lambda (c) 514 (make-child 515 (child-pict c) 516 (child-dx c) 517 (+ dh (child-dy c)) 518 1 1 519 0 0)) 520 (pict-children p)) 521 #f 522 (pict-last p)))) 523 524(define (drop-below-ascent p n) 525 (let* ([dh (- (max 0 (- n (pict-ascent p))))] 526 [do-d? (= (pict-height p) 527 (+ (pict-ascent p) (pict-descent p)))] 528 [h2 (+ dh (pict-height p))] 529 [a2 (max 0 (- (pict-ascent p) n))]) 530 (make-pict (pict-draw p) 531 (pict-width p) h2 532 a2 533 (if do-d? 534 (- h2 a2) 535 (pict-descent p)) 536 (pict-children p) 537 #f 538 (pict-last p)))) 539 540(define (baseless p) 541 (let ([p (lift-above-baseline p (pict-descent p))]) 542 (drop-below-ascent p (- (pict-ascent p) (pict-height p))))) 543 544(define (refocus p c) 545 (let-values ([(x y) (find-lt p c)]) 546 (let ([p (inset p 547 (- x) (- y (pict-height p)) 548 (- (- (pict-width p) x (pict-width c))) 549 (- (pict-height c) y))]) 550 (make-pict (pict-draw p) 551 (pict-width c) (pict-height c) 552 (pict-ascent c) (pict-descent c) 553 (pict-children p) 554 #f 555 (last* c))))) 556 557(define (panorama-box! p*) 558 (let* ([p (pict-convert p*)] 559 [bb (pict-panbox p)]) 560 (if bb 561 (values (bbox-x1 bb) (bbox-y1 bb) (bbox-x2 bb) (bbox-y2 bb) 562 (bbox-ay bb) (bbox-dy bb)) 563 (let loop ([x1 0][y1 0][x2 (pict-width p)][y2 (pict-height p)] 564 [ay (- (pict-height p) (pict-ascent p))][dy (pict-descent p)] 565 [l (pict-children p)]) 566 (if (null? l) 567 (begin 568 (set-pict-panbox! p (make-bbox x1 y1 x2 y2 ay dy)) 569 (values x1 y1 x2 y2 ay dy)) 570 (let ([c (car l)]) 571 (let-values ([(cx1 cy1 cx2 cy2 cay cdy) (panorama-box! (child-pict c))]) 572 (loop (min x1 (+ (* cx1 (child-sx c)) (child-dx c))) 573 (min y1 (+ (* cy1 (child-sy c)) (child-dy c))) 574 (max x2 (+ (* cx2 (child-sx c)) (child-dx c))) 575 (max y2 (+ (* cy2 (child-sy c)) (child-dy c))) 576 (max ay (+ (* cay (child-sy c)) (child-dy c))) 577 (min dy (+ (* cdy (child-sy c)) (child-dy c))) 578 (cdr l))))))))) 579 580(define (panorama p) 581 (let-values ([(x1 y1 x2 y2 ay dy) (panorama-box! p)]) 582 (let ([h (- y2 y1)]) 583 (place-over (blank (- x2 x1) h (- h ay) dy) 584 (- x1) (- y2 (pict-height p)) 585 p)))) 586 587(define (clip-descent b) 588 (let* ([w (pict-width b)] 589 [h (pict-height b)] 590 [d (pict-descent b)]) 591 (extend-pict 592 b 0 (- d) 593 0 0 (- d) 594 `(picture ,w ,(- h d) 595 (put 0 ,(- d) ,(pict-draw b)))))) 596 597(define (clip-ascent b) 598 (let* ([w (pict-width b)] 599 [h (pict-height b)] 600 [a (pict-ascent b)]) 601 (extend-pict 602 b 0 a 603 0 (- a) 0 604 `(picture ,w ,(- h a) 605 (put 0 0 ,(pict-draw b)))))) 606 607(define (thickness mode b) 608 (let* ([w (pict-width b)] 609 [h (pict-height b)]) 610 (extend-pict 611 b 0 0 0 0 0 612 `(picture ,w ,h 613 (thickness ,mode ,(pict-draw b)))))) 614 615(define (thick b) (thickness 'thicklines b)) 616(define (thin b) (thickness 'thinlines b)) 617(define (line-thickness n b) (thickness n b)) 618(define (line-style n s) (thickness n s)) 619 620(define inset 621 (case-lambda 622 [(box a) (inset box a a a a)] 623 [(box h v) (inset box h v h v)] 624 [(box l t r b) 625 (let ([w (+ l r (pict-width box))] 626 [h (+ t b (pict-height box))]) 627 (extend-pict 628 box l b 629 (+ l r) t b 630 `(picture 631 ,w ,h 632 (put ,l ,b ,(pict-draw box)))))])) 633 634(define (use-last* p sub-p) 635 (use-last p (last* sub-p))) 636 637(define (last* sub-p) 638 ;; Either use `sub-p' for last or create a path though `sub-p' 639 ;; to the last of `sub-p' (in case the last of `sub-p' is also 640 ;; in other places within `p') 641 (let ([l (pict-last sub-p)]) 642 (cond 643 [(not l) sub-p] 644 [(pair? l) (if (pict-path-element=? (car l) sub-p) 645 l 646 (cons sub-p l))] 647 [(pict-path-element=? l sub-p) sub-p] 648 [else (list sub-p l)]))) 649 650(define (use-last p sub-p) 651 (if (let floop ([p p] [sub-p sub-p]) 652 (or 653 (if (not (pair? sub-p)) 654 (pict-path-element=? p sub-p) 655 (and (not (pair? (car sub-p))) 656 (pict-path-element=? p (car sub-p)) 657 (or (null? (cdr sub-p)) 658 (floop p (cdr sub-p))))) 659 (ormap (lambda (c) (floop (child-pict c) sub-p)) 660 (pict-children p)))) 661 (use-last/unchecked p sub-p) 662 (error 'use-last 663 "given new last-pict path: ~e not in the base pict: ~e" 664 sub-p 665 p))) 666 667(define (use-last/unchecked p sub-p) 668 (make-pict (pict-draw p) 669 (pict-width p) (pict-height p) 670 (pict-ascent p) (pict-descent p) 671 (list (make-child p 0 0 1 1 0 0)) 672 #f 673 sub-p)) 674 675(define dash-frame 676 (case-lambda 677 [(box) (dash-frame box default-seg)] 678 [(box seg) 679 (let* ([w (pict-width box)] 680 [h (pict-height box)]) 681 (extend-pict 682 box 0 0 0 0 0 683 `(picture 684 ,w ,h 685 (put 0 0 ,(pict-draw box)) 686 (put 0 0 ,(pict-draw (dash-hline w 0 seg))) 687 (put 0 ,h ,(pict-draw (dash-hline w 0 seg))) 688 (put 0 0 ,(pict-draw (dash-vline 0 h seg))) 689 (put ,w 0 ,(pict-draw (dash-vline 0 h seg))))))])) 690 691(define (frame box) 692 (let ([box (pict-convert box)]) 693 (dash-frame box (max (pict-width box) (pict-height box))))) 694 695(define (dash-line width height rotate seg) 696 (let ([vpos (/ height 2)]) 697 (make-pict 698 `(picture 699 ,@(rotate width height) 700 ,@(if (>= seg width) 701 `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,width))) 702 (let () 703 (define seg*2 (* seg 2)) 704 (define count (inexact->exact (truncate (/ width seg*2)))) 705 (define remain/2 (/ (- width (* seg*2 count)) 2)) 706 `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,remain/2)) 707 ,@(let loop ([count count] [pos remain/2]) 708 (if (zero? count) 709 null 710 (cons `(put ,@(rotate (+ pos seg) vpos) 711 (line ,@(rotate 1 0) ,seg)) 712 (loop (sub1 count) (+ pos seg*2))))) 713 (put ,@(rotate (- width remain/2) vpos) 714 (line ,@(rotate 1 0) ,remain/2)))))) 715 (car (rotate width height)) 716 (cadr (rotate width height)) 717 (cadr (rotate 0 height)) 0 718 null 719 #f 720 #f))) 721 722(define (rlist b a) (list a b)) 723 724(define (hline width height) 725 (dash-line width height list width)) 726 727(define (vline width height) 728 (dash-line height width rlist height)) 729 730(define dash-hline 731 (case-lambda 732 [(width height) (dash-hline width height default-seg)] 733 [(width height seg) (dash-line width height list seg)])) 734 735(define dash-vline 736 (case-lambda 737 [(width height) (dash-vline width height default-seg)] 738 [(width height seg) (dash-line height width rlist seg)])) 739 740(define (oval box) 741 (let ([w (pict-width box)] 742 [h (pict-height box)]) 743 (extend-pict 744 box 0 0 0 0 0 745 `(picture 746 ,w ,h 747 (put 0 0 ,(pict-draw box)) 748 (put ,(/ w 2) ,(/ h 2) (oval "" ,w ,h)))))) 749 750(define (oval/radius box r) 751 (let* ([w (pict-width box)] 752 [h (pict-height box)] 753 [rr (* 2 r)] 754 [lw (- w rr)] 755 [lh (- h rr)]) 756 (extend-pict 757 box 0 0 0 0 0 758 `(picture 759 ,w ,h 760 (put 0 0 ,(pict-draw box)) 761 (put ,r ,r (oval "[bl]" ,rr ,rr)) 762 (put ,r 0 (line 1 0 ,lw)) 763 (put ,(- w r) ,r (oval "[br]" ,rr ,rr)) 764 (put ,w ,r (line 0 1 ,lh)) 765 (put ,r ,(- h r) (oval "[tl]" ,rr ,rr)) 766 (put ,r ,h (line 1 0 ,lw)) 767 (put ,(- w r) ,(- h r) (oval "[tr]" ,rr ,rr)) 768 (put ,0 ,r (line 0 1 ,lh)))))) 769 770(define (big-circle d) 771 (let ([r (/ d 2)]) 772 (picture 773 d d 774 `((curve 0 ,r ,r 0 0 0) 775 (curve ,r 0 ,d ,r ,d 0) 776 (curve ,d ,r ,r ,d ,d ,d) 777 (curve ,r ,d 0 ,r 0 ,d))))) 778 779(define (ghost box) 780 (let ([w (pict-width box)] 781 [h (pict-height box)]) 782 (extend-pict 783 box 0 0 0 0 0 784 `(picture 785 ,w ,h)))) 786 787(define-values (vl-append 788 vc-append 789 vr-append 790 ht-append 791 hc-append 792 hb-append 793 htl-append 794 hbl-append) 795 (let ([make-append-boxes 796 (lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset 797 combine-ascent combine-descent) 798 (let ([do-append 799 (lambda (sep args) 800 (let append-boxes ([args args]) 801 (cond 802 [(null? args) (blank)] 803 [(null? (cdr args)) (pict-convert (car args))] 804 [else 805 (let* ([first (pict-convert (car args))] 806 [rest (append-boxes (cdr args))] 807 [w (wcomb (pict-width first) (pict-width rest) sep first rest)] 808 [h (hcomb (pict-height first) (pict-height rest) sep first rest)] 809 [fw (pict-width first)] 810 [fh (pict-height first)] 811 [rw (pict-width rest)] 812 [rh (pict-height rest)] 813 [fd1 (pict-ascent first)] 814 [fd2 (pict-descent first)] 815 [rd1 (pict-ascent rest)] 816 [rd2 (pict-descent rest)] 817 [dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] 818 [dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)] 819 [dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] 820 [dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2 h)]) 821 (make-pict 822 `(picture 823 ,w ,h 824 (put ,dx1 825 ,dy1 826 ,(pict-draw first)) 827 (put ,dx2 828 ,dy2 829 ,(pict-draw rest))) 830 w h 831 (combine-ascent fd1 rd1 fd2 rd2 fh rh h (+ dy1 fh) (+ dy2 rh)) 832 (combine-descent fd2 rd2 fd1 rd1 fh rh h (- h dy1) (- h dy2)) 833 (list (make-child first dx1 dy1 1 1 0 0) 834 (make-child rest dx2 dy2 1 1 0 0)) 835 #f 836 (last* rest)))])))]) 837 (let ([*-append (case-lambda 838 [() (do-append 0 null)] 839 [(sep . args) 840 (if (number? sep) 841 (do-append sep args) 842 (do-append 0 (cons sep args)))])]) 843 *-append)))] 844 [2max (lambda (a b c . rest) (max a b))] 845 [zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 . args) 0)] 846 [fv (lambda (a b . args) a)] 847 [sv (lambda (a b . args) b)] 848 [min2 (lambda (a b . args) (min a b))] 849 [max2 (lambda (a b . args) (max a b))] 850 [3+ (lambda (a b c . args) (+ a b c))] 851 [a-max (lambda (a b c first rest) 852 (+ (max (pict-ascent first) (pict-ascent rest)) 853 (max (- (pict-height first) (pict-ascent first)) 854 (- (pict-height rest) (pict-ascent rest)))))] 855 [d-max (lambda (a b c first rest) 856 (+ (max (pict-descent first) (pict-descent rest)) 857 (max (- (pict-height first) (pict-descent first)) 858 (- (pict-height rest) (pict-descent rest)))))] 859 [min-ad (lambda (a b oa ob ah bh h da db) 860 (- h (max oa ob) (max (- ah oa a) 861 (- bh ob b))))] 862 [xmin-ad (lambda (a b oa ob ah bh h da db) 863 (min (+ (- h da) a) (+ (- h db) b)))]) 864 (values 865 (make-append-boxes 2max 3+ 866 zero (lambda (fw fh rw rh sep . a) (+ sep rh)) 867 zero zero 868 fv sv) 869 (make-append-boxes 2max 3+ 870 (lambda (fw fh rw rh sep . a) (/ (- (max fw rw) fw) 2)) 871 (lambda (fw fh rw rh sep . a) (+ sep rh)) 872 (lambda (fw fh rw rh sep . a) (/ (- (max fw rw) rw) 2)) 873 zero 874 fv sv) 875 (make-append-boxes 2max 3+ 876 (lambda (fw fh rw rh sep . a) (- (max fw rw) fw)) 877 (lambda (fw fh rw rh sep . a) (+ sep rh)) 878 (lambda (fw fh rw rh sep . a) (- (max fw rw) rw)) 879 zero 880 fv sv) 881 (make-append-boxes 3+ 2max 882 zero 883 (lambda (fw fh rw rh sep . a) (- (max fh rh) fh)) 884 (lambda (fw fh rw rh sep . a) (+ sep fw)) 885 (lambda (fw fh rw rh sep . a) (- (max fh rh) rh)) 886 xmin-ad xmin-ad) 887 (make-append-boxes 3+ 2max 888 zero 889 (lambda (fw fh rw rh sep . a) (/ (- (max fh rh) fh) 2)) 890 (lambda (fw fh rw rh sep . a) (+ sep fw)) 891 (lambda (fw fh rw rh sep . a) (/ (- (max fh rh) rh) 2)) 892 xmin-ad xmin-ad) 893 (make-append-boxes 3+ 2max 894 zero zero 895 (lambda (fw fh rw rh sep . a) (+ sep fw)) zero 896 xmin-ad xmin-ad) 897 (make-append-boxes 3+ a-max 898 zero 899 (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 900 (- h fh (- (max fd1 rd1) fd1))) 901 (lambda (fw fh rw rh sep . a) (+ sep fw)) 902 (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 903 (- h rh (- (max fd1 rd1) rd1))) 904 max2 min-ad) 905 (make-append-boxes 3+ d-max 906 zero 907 (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 908 (- (max fd2 rd2) fd2)) 909 (lambda (fw fh rw rh sep . a) (+ sep fw)) 910 (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2 h) 911 (- (max fd2 rd2) rd2)) 912 min-ad max2)))) 913 914(define-values (lt-superimpose 915 lb-superimpose 916 lc-superimpose 917 ltl-superimpose 918 lbl-superimpose 919 rt-superimpose 920 rb-superimpose 921 rc-superimpose 922 rtl-superimpose 923 rbl-superimpose 924 ct-superimpose 925 cb-superimpose 926 cc-superimpose 927 ctl-superimpose 928 cbl-superimpose) 929 (let ([make-superimpose 930 (lambda (get-h get-v get-th name) 931 (lambda boxes* 932 (when (null? boxes*) 933 (error name "expected at least one argument, got none")) 934 (define boxes 935 (map 936 (lambda (p) 937 (cond 938 [(pict? p) p] 939 [(pict-convertible? p) 940 (pict-convert p)] 941 [else 942 (raise-argument-error 943 name "all picts as arguments" 944 (apply string-append (add-between (map (λ (x) (format "~e" x)) boxes*) " ")))])) 945 boxes*)) 946 (let ([max-w (apply max (map pict-width boxes))] 947 [max-h (apply max (map pict-height boxes))] 948 [max-a (apply max (map pict-ascent boxes))] 949 [max-a-complement (apply max (map (lambda (b) (- (pict-height b) (pict-ascent b))) 950 boxes))] 951 [max-d (apply max (map pict-descent boxes))] 952 [max-d-complement (apply max (map (lambda (b) (- (pict-height b) (pict-descent b))) 953 boxes))]) 954 (let ([p (picture max-w (get-th max-h max-a max-d max-a-complement max-d-complement) 955 (map (lambda (box) 956 `(place ,(get-h max-w (pict-width box)) 957 ,(get-v max-h (pict-height box) 958 max-d (pict-descent box) 959 max-a-complement (pict-ascent box)) 960 ,box)) 961 boxes))]) 962 ;; Figure out top and bottom baselines by finding the picts again, etc: 963 (let ([ys (map (lambda (box) 964 (let-values ([(x y) (find-lt p box)]) 965 y)) 966 boxes)]) 967 (let ([min-a (apply min (map (lambda (box y) 968 (+ (- (pict-height p) y) (pict-ascent box))) 969 boxes ys))] 970 [min-d (apply min (map (lambda (box y) 971 (+ (- y (pict-height box)) (pict-descent box))) 972 boxes ys))]) 973 (make-pict (pict-draw p) 974 (pict-width p) (pict-height p) 975 min-a min-d 976 (pict-children p) 977 #f 978 ;; Find bottomost, rightmost of old last picts to be the 979 ;; new last pict. 980 (let ([subs (map (lambda (box) 981 (let ([last (last* box)]) 982 (let-values ([(x y) (rb-find p last)]) 983 (list last x y)))) 984 boxes)]) 985 (if (null? subs) 986 #f 987 (caar (sort subs 988 (lambda (a b) 989 (let ([ay (caddr a)] 990 [by (caddr b)]) 991 (cond 992 [(ay . > . by) #t] 993 [(= ay by) ((cadr a) . > . (cadr b))] 994 [else #f]))))))))))))))] 995 [norm (lambda (h a d ac dc) h)] 996 [tbase (lambda (h a d ac dc) (+ a ac))] 997 [bbase (lambda (h a d ac dc) (+ d dc))] 998 [lb (lambda (m v . rest) 0)] 999 [rt (lambda (m v . rest) (- m v))] 1000 [tline (lambda (m v md d mac a) (- mac (- v a)))] 1001 [bline (lambda (m v md d mac a) (- md d))] 1002 [c (lambda (m v . rest) (/ (- m v) 2))]) 1003 (values 1004 (make-superimpose lb rt norm 'lt-superimpose) 1005 (make-superimpose lb lb norm 'lb-superimpose) 1006 (make-superimpose lb c norm 'lc-superimpose) 1007 (make-superimpose lb tline tbase 'ltl-superimpose) 1008 (make-superimpose lb bline bbase 'lbl-superimpose) 1009 (make-superimpose rt rt norm 'rt-superimpose) 1010 (make-superimpose rt lb norm 'rb-superimpose) 1011 (make-superimpose rt c norm 'rc-superimpose) 1012 (make-superimpose rt tline tbase 'rtl-superimpose) 1013 (make-superimpose rt bline bbase 'rbl-superimpose) 1014 (make-superimpose c rt norm 'ct-superimpose) 1015 (make-superimpose c lb norm 'cb-superimpose) 1016 (make-superimpose c c norm 'cc-superimpose) 1017 (make-superimpose c tline tbase 'ctl-superimpose) 1018 (make-superimpose c bline bbase 'cbl-superimpose)))) 1019 1020(define table 1021 (case-lambda 1022 [(ncol cells col-aligns row-aligns col-seps row-seps) 1023 (let ([count (length cells)]) 1024 (unless (zero? (remainder count ncol)) 1025 (error 'table "cell count isn't divisble by the provided column count")) 1026 (let* ([w ncol] 1027 [h (/ count w)] 1028 [cells (let rloop ([r h][cells cells][r-acc null]) 1029 (if (zero? r) 1030 (list->vector (reverse r-acc)) 1031 (let loop ([c w][cells cells][one-acc null]) 1032 (if (zero? c) 1033 (rloop (sub1 r) cells (cons (list->vector (reverse one-acc)) r-acc)) 1034 (loop (sub1 c) (cdr cells) (cons (pict-convert (car cells)) one-acc))))))] 1035 [imp-list->vector (lambda (l n) 1036 (let ([v (make-vector n)]) 1037 (let loop ([l l][p 0]) 1038 (unless (= n p) 1039 (vector-set! v 1040 p 1041 (if (pair? l) 1042 (car l) 1043 l)) 1044 (loop (if (pair? l) (cdr l) l) (add1 p)))) 1045 v))] 1046 [ralign (imp-list->vector row-aligns h)] 1047 [calign (imp-list->vector col-aligns w)] 1048 [rsep (imp-list->vector row-seps h)] 1049 [csep (imp-list->vector col-seps w)] 1050 [get-cell (lambda (c r) (vector-ref (vector-ref cells r) c))] 1051 [nmap (lambda (f w) 1052 (let loop ([n w][acc null]) 1053 (if (zero? n) 1054 acc 1055 (loop (sub1 n) (cons (f (sub1 n)) acc)))))] 1056 [rowmap (lambda (f) (nmap f h))] 1057 [colmap (lambda (f) (nmap f w))] 1058 [superimposed-rows (list->vector 1059 (rowmap (lambda (r) 1060 (apply 1061 (vector-ref ralign r) 1062 (colmap (lambda (c) (get-cell c r)))))))] 1063 [superimposed-cols (list->vector 1064 (colmap (lambda (c) 1065 (apply 1066 (vector-ref calign c) 1067 (rowmap (lambda (r) (get-cell c r)))))))]) 1068 ; No space after the last row/col 1069 (vector-set! rsep (sub1 h) 0) 1070 (vector-set! csep (sub1 w) 0) 1071 1072 (apply 1073 vl-append 1074 0 1075 (rowmap 1076 (lambda (r) 1077 (vl-append 1078 0 1079 (apply 1080 ht-append 1081 0 1082 (colmap (lambda (c) 1083 (ht-append 1084 0 1085 (let* ([cell (get-cell c r)] 1086 [sc (vector-ref superimposed-cols c)] 1087 [sr (vector-ref superimposed-rows r)] 1088 [w (pict-width sc)] 1089 [h (pict-height sr)]) 1090 (let-values ([(x __) (find-lb sc cell)] 1091 [(_ y) (find-lb sr cell)]) 1092 (picture 1093 w h 1094 `((place ,x ,y ,cell))))) 1095 (blank (vector-ref csep c) 0))))) 1096 (blank 0 (vector-ref rsep r))))))))])) 1097 1098(define (record title . fields) 1099 (let* ([totalwidth (apply max (pict-width title) (map pict-width fields))] 1100 [linespace (if (null? fields) 0 recordseplinespace)] 1101 [totalheight (+ (pict-height title) (apply + (map pict-height fields)) 1102 linespace)] 1103 [title-y (- totalheight (pict-height title))] 1104 [field-ys (let loop ([pos (- totalheight (pict-height title) linespace)] 1105 [fields fields]) 1106 (if (null? fields) 1107 null 1108 (let* ([p (- pos (pict-height (car fields)))]) 1109 (cons p 1110 (loop p (cdr fields))))))]) 1111 (make-pict 1112 `(picture 1113 ,totalwidth ,totalheight 1114 (put 0 0 (line 1 0 ,totalwidth)) 1115 (put 0 ,totalheight (line 1 0 ,totalwidth)) 1116 (put 0 0 (line 0 1 ,totalheight)) 1117 (put ,totalwidth 0 (line 0 1 ,totalheight)) 1118 (put 0 ,title-y ,(pict-draw title)) 1119 ,@(if (null? fields) 1120 '() 1121 `((put 0 ,(- totalheight (pict-height title) (/ linespace 2)) 1122 (line 1 0 ,totalwidth)))) 1123 ,@(map (lambda (f p) `(put 0 ,p ,(pict-draw f))) 1124 fields field-ys)) 1125 totalwidth totalheight 1126 totalheight 0 1127 (cons 1128 (make-child title 0 title-y 1 1 0 0) 1129 (map (lambda (child child-y) (make-child child 0 child-y 1 1 0 0)) fields field-ys)) 1130 #f 1131 #f))) 1132 1133(define (picture* w h a d commands) 1134 (let loop ([commands commands][translated null][children null]) 1135 (if (null? commands) 1136 (make-pict 1137 `(picture ,w ,h 1138 ,@(reverse translated)) 1139 w h a d 1140 children 1141 #f 1142 #f) 1143 (let ([c (car commands)] 1144 [rest (cdr commands)]) 1145 (unless (and (pair? c) (symbol? (car c))) 1146 (error 'picture "bad command: ~a" c)) 1147 (case (car c) 1148 [(connect) (loop rest 1149 (append (apply connect (cdr c)) 1150 translated) 1151 children)] 1152 [(dconnect) (loop rest 1153 (let ([x (cadr c)] 1154 [y (caddr c)] 1155 [dx (cadddr c)] 1156 [dy (list-ref c 4)]) 1157 (append (connect x y (+ x dx) (+ y dy) 1158 (if (null? (list-tail c 5)) 1159 #t 1160 (list-ref c 5))) 1161 translated)) 1162 children)] 1163 [(connect~y) (loop rest 1164 (append (apply ~connect 'x (cdr c)) 1165 translated) 1166 children)] 1167 [(connect~x) (loop rest 1168 (append (apply ~connect 'y (cdr c)) 1169 translated) 1170 children)] 1171 [(connect~xy) (loop rest 1172 (append (apply ~connect 'r (cdr c)) 1173 translated) 1174 children)] 1175 [(curve) (loop rest 1176 (let ([x1 (cadr c)] 1177 [y1 (caddr c)] 1178 [x2 (cadddr c)] 1179 [y2 (list-ref c 4)] 1180 [xm (list-ref c 5)] 1181 [ym (list-ref c 6)] 1182 [d (if (null? (list-tail c 7)) 1183 1.0 1184 (list-ref c 7))]) 1185 (let ([p (if (and d (>= d 0)) 1186 (inexact->exact (floor (* d (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))))) 1187 #f)]) 1188 (if (and (= x1 x2) (= y1 y2)) 1189 translated 1190 (cons `(qbezier ,p ,x1 ,y1 ,xm ,ym ,x2 ,y2) 1191 translated)))) 1192 children)] 1193 [(place) (let ([x (cadr c)] 1194 [y (caddr c)] 1195 [p (cadddr c)]) 1196 (loop rest 1197 (cons 1198 `(put ,x ,y ,(pict-draw p)) 1199 translated) 1200 (cons 1201 (make-child p x y 1 1 0 0) 1202 children)))] 1203 [else (loop rest (cons c translated) children)]))))) 1204 1205(define (picture w h commands) 1206 (picture* w h h 0 commands)) 1207 1208(define (cons-picture p commands) 1209 (picture 1210 (pict-width p) (pict-height p) 1211 (cons 1212 `(place 0 0 ,p) 1213 commands))) 1214 1215(define (cons-picture* p commands) 1216 (picture* 1217 (pict-width p) (pict-height p) 1218 (pict-ascent p) (pict-descent p) 1219 (cons 1220 `(place 0 0 ,p) 1221 commands))) 1222 1223(define (place-it who flip? base dx dy target) 1224 (let-values ([(dx dy) 1225 (cond 1226 [(and (number? dx) (number? dy)) 1227 (values dx (- (pict-height base) dy))] 1228 [(and (pict-path? dx) 1229 (procedure? dy) 1230 (procedure-arity-includes? dy 2)) 1231 (if flip? 1232 (let-values ([(dx dy) (dy base dx)]) 1233 (values dx (- (pict-height base) dy))) 1234 (dy base dx))] 1235 [else 1236 (error who 1237 "expects two numbers or a sub-pict and a find procedure")])]) 1238 (use-last/unchecked (cons-picture* 1239 base 1240 `((place ,dx ,(- dy (pict-height target)) ,target))) 1241 (last* base)))) 1242 1243(define (place-over base dx dy target) 1244 (place-it 'place-over #f base dx dy target)) 1245(define (place-under base dx dy target) 1246 (cc-superimpose 1247 (place-it 'place-under #f (ghost base) dx dy target) 1248 base)) 1249 1250(define (pin-over base dx dy target) 1251 (place-it 'pin-over #t base dx dy target)) 1252(define (pin-under base dx dy target) 1253 (cc-superimpose 1254 (place-it 'pin-under #t (ghost base) dx dy target) 1255 (launder base))) 1256 1257(define black-and-white 1258 (make-parameter #f 1259 (lambda (x) 1260 (and x #t)))) 1261 1262(define (colorize p color) 1263 (unless (or (string? color) 1264 (is-a? color color%) 1265 (and (list? color) (= 3 (length color)) (andmap byte? color))) 1266 (error 'colorize "expected a color, given ~e" color)) 1267 (let ([color (if (list? color) 1268 (apply make-color color) 1269 color)]) 1270 (if (black-and-white) 1271 p 1272 (extend-pict 1273 p 0 0 0 0 0 1274 `(color ,color ,(pict-draw p)))))) 1275 1276(define (optimize s) 1277 (let o-loop ([s s][dx 0][dy 0]) 1278 (if (string? s) 1279 s 1280 (let ([tag (car s)]) 1281 (case tag 1282 [(picture) 1283 (list* 'picture (cadr s) (caddr s) 1284 (map optimize (cdddr s)))] 1285 [(color) 1286 (let ([next (caddr s)]) 1287 (if (and (pair? next) (eq? (car next) 'color)) 1288 (optimize next) 1289 (list* 'color (cadr s) 1290 (list 'put dx dy (optimize next)))))] 1291 [(thickness) 1292 (let ([t (cadr s)] 1293 [p (caddr s)]) 1294 (list 'put dx dy 1295 (list 'thickness t 1296 (optimize p))))] 1297 [(put) 1298 (let ([x (cadr s)] 1299 [y (caddr s)] 1300 [next (cadddr s)]) 1301 (if (and (pair? next) (eq? (car next) 'picture)) 1302 ; optmize put-picture to just contents ... 1303 (cons 'begin (map (lambda (s) (o-loop s (+ x dx) (+ y dy))) (cdddr next))) 1304 ; normal 1305 (list 'put (+ x dx) (+ y dy) (optimize next))))] 1306 [(qbezier) 1307 (let ([x1 (list-ref s 2)] 1308 [y1 (list-ref s 3)] 1309 [xm (list-ref s 4)] 1310 [ym (list-ref s 5)] 1311 [x2 (list-ref s 6)] 1312 [y2 (list-ref s 7)] 1313 [p (list-ref s 1)]) 1314 (list 'qbezier p 1315 (+ x1 dx) (+ y1 dy) 1316 (+ xm dx) (+ ym dy) 1317 (+ x2 dx) (+ y2 dy)))] 1318 [(frame) 1319 (list 'frame (optimize (cadr s)))] 1320 [(colorbox) 1321 (list 'colorbox (cadr s) (optimize (caddr s)))] 1322 [(line vector dirline dirvector circle circle* make-box oval prog) s] 1323 [else (error 'optimize "bad tag: ~s" tag)]))))) 1324 1325(define (fixup-top s) 1326 (cond 1327 [(and (pair? s) (eq? (car s) 'color)) 1328 ;; Drop initial put 1329 (list* 'color (cadr s) (caddr (cdddr s)))] 1330 [(and (pair? s) (eq? (car s) 'put)) 1331 ;; Wrap initial put (from thickness) in a pair of braces 1332 `(local ,(cadddr s))] 1333 [else 1334 ;; Do nothing 1335 s])) 1336 1337(define (prepare-for-output s) 1338 (fixup-top (optimize (pict-draw s)))) 1339 1340(define (pict->command-list s) 1341 (let output ([s (prepare-for-output s)]) 1342 (if (string? s) 1343 (list s) 1344 (let ([tag (car s)]) 1345 (case tag 1346 [(local) 1347 (output (cadr s))] 1348 [(begin) 1349 (apply append (map output (cdr s)))] 1350 [(picture) 1351 (apply append (map output (cdddr s)))] 1352 [(color) 1353 `((with-color ,(cadr s) ,(output (cddr s))))] 1354 [(thickness) 1355 `((with-thickness ,(cadr s) ,(output (caddr s))))] 1356 [(put) 1357 `((offset ,(cadr s) ,(caddr s) ,(output (cadddr s))))] 1358 [(qbezier) 1359 `((bezier ,@(cddr s)))] 1360 [(line vector) 1361 `((,tag ,(cadr s) ,(caddr s) ,(cadddr s)))] 1362 [(circle circle*) 1363 `((,tag ,(cadr s)))] 1364 [(frame) 1365 `((frame ,(output (cadr s))))] 1366 [(colorbox) 1367 `((colorbox ,(cadr s) ,(output (caddr s))))] 1368 [(oval) 1369 `((oval ,(caddr s) ,(cadddr s) ,(cadr s)))] 1370 [(make-box) 1371 `((make-box ,(cadr s) ,(caddr s) ,(cadddr s) ,(car (cddddr s))))] 1372 [(prog) 1373 `((prog ,(cadr s) ,(caddr s)))] 1374 [else (error 'pict->commands "bad tag: ~s" tag)]))))) 1375 1376 1377 1378(define show-pict 1379 (λ (p [w #f] 1380 [h #f] 1381 #:frame-style [frame-style '()] 1382 #:frame-x [frame-x #f] 1383 #:frame-y [frame-y #f]) 1384 (define the-pict p) 1385 (define pict-drawer (make-pict-drawer the-pict)) 1386 (define no-redraw? #f) 1387 (define pict-frame% 1388 (class (gui-dynamic-require 'frame%) 1389 (define/public (set-pict p) 1390 (set! the-pict p) 1391 (set! pict-drawer (make-pict-drawer the-pict)) 1392 (set! no-redraw? #t) 1393 (let ([pw (inexact->exact (floor (pict-width the-pict)))] 1394 [ph (inexact->exact (floor (pict-height the-pict)))]) 1395 (send c min-width (if w (max w pw) pw)) 1396 (send c min-height (if h (max h ph) ph))) 1397 (set! no-redraw? #f) 1398 (send c on-paint)) 1399 (super-instantiate ()))) 1400 (define pict-canvas% 1401 (class (gui-dynamic-require 'canvas%) 1402 (inherit get-dc) 1403 (define/override (on-paint) 1404 (unless no-redraw? 1405 (let ([dc (get-dc)]) 1406 (send dc clear) 1407 (let* ([pw (pict-width the-pict)] 1408 [ph (pict-height the-pict)] 1409 [xo (if (and w 1410 (pw . < . w)) 1411 (- (/ w 2) (/ pw 2)) 1412 0)] 1413 [yo (if (and h 1414 (ph . < . h)) 1415 (- (/ h 2) (/ ph 2)) 1416 0)]) 1417 (pict-drawer dc xo yo))))) 1418 (super-instantiate ()))) 1419 (define f (new pict-frame% 1420 [label "MrPict"] 1421 [style frame-style] 1422 [x frame-x] 1423 [y frame-y])) 1424 (define c (make-object pict-canvas% f)) 1425 (send (send c get-dc) set-smoothing 'aligned) 1426 (send f set-pict p) 1427 (send f show #t))) 1428 1429(define dc-for-text-size (make-parameter 1430 (make-object bitmap-dc% (make-bitmap 1 1)) 1431 (lambda (x) 1432 (unless (or (not x) 1433 (is-a? x dc<%>)) 1434 (raise-argument-error 'dc-for-parameter "(or/c (is-a?/c dc<%>) #f)" x)) 1435 x))) 1436 1437(define convert-bounds-padding 1438 (make-parameter 1439 (list 3 3 3 3) 1440 (lambda (x) 1441 (unless (and (list? x) (= 4 (length x)) (andmap real? x) 1442 (andmap (lambda (i) (not (negative? i))) x)) 1443 (raise-argument-error 'convert-bounds-padding 1444 "(list/c (>=/c 0) (>=/c 0) (>=/c 0) (>=/c 0))" 1445 x)) 1446 x))) 1447 1448(define (dc f w h [a h] [d 0]) 1449 (make-pict `(prog ,f ,h) w h a d null #f #f)) 1450 1451(define prog-picture dc) 1452 1453(define current-expected-text-scale (make-parameter (list 1 1))) 1454(define (with-text-scale dc thunk) 1455 (let ([x (current-expected-text-scale)]) 1456 (if (equal? x '(1 1)) 1457 (thunk) 1458 (let-values ([(xs ys) (send dc get-scale)]) 1459 (send dc set-scale (* xs (car x)) (* ys (cadr x))) 1460 (let-values ([(w h d s) (thunk)]) 1461 (send dc set-scale xs ys) 1462 (values w h d s)))))) 1463 1464(define (memq* a l) 1465 (if (pair? l) 1466 (or (eq? (car l) a) 1467 (memq* a (cdr l))) 1468 #f)) 1469 1470(define (extend-font font size style weight hinting) 1471 (if (send font get-face) 1472 (send the-font-list find-or-create-font 1473 size 1474 (send font get-face) 1475 (send font get-family) 1476 style 1477 weight 1478 #f 1479 'default 1480 #t 1481 hinting) 1482 (send the-font-list find-or-create-font 1483 size 1484 (send font get-family) 1485 style 1486 weight 1487 #f 1488 'default 1489 #t 1490 hinting))) 1491 1492(define text 1493 (case-lambda 1494 [(string) (text string '() 12)] 1495 [(string style) (text string style 12)] 1496 [(string style size) (text string style size 0)] 1497 [(str style size angle) 1498 (if (il-memq 'caps style) 1499 (begin 1500 (unless (zero? angle) 1501 (error 'text "the style cannot include 'caps with a non-zero angle")) 1502 (caps-text str (il-remq 'caps style) size)) 1503 (not-caps-text str style size angle))])) 1504 1505(define families '(default decorative roman script swiss modern symbol system)) 1506 1507(define (il-memq sym s) 1508 (and (pair? s) 1509 (or (eq? sym (car s)) 1510 (il-memq sym (cdr s))))) 1511(define (il-remq sym s) 1512 (if (pair? s) 1513 (if (eq? sym (car s)) 1514 (cdr s) 1515 (cons (car s) (il-remq sym (cdr s)))) 1516 s)) 1517 1518(define (not-caps-text string orig-style size angle) 1519 (let ([font 1520 (let loop ([style orig-style]) 1521 (cond 1522 [(null? style) 1523 (send the-font-list find-or-create-font 1524 size 'default 'normal 'normal #f 'default #t 'unaligned)] 1525 [(is-a? style font%) 1526 style] 1527 [(memq style families) 1528 (send the-font-list find-or-create-font 1529 size style 'normal 'normal #f 'default #t 'unaligned)] 1530 [(string? style) 1531 (send the-font-list find-or-create-font 1532 size style 'default 'normal 'normal #f 'default #t 'unaligned)] 1533 [(and (pair? style) 1534 (string? (car style)) 1535 (memq (cdr style) families)) 1536 (send the-font-list find-or-create-font 1537 size (car style) (cdr style) 'normal 'normal #f 'default #t 'unaligned)] 1538 [(and (pair? style) 1539 (memq (car style) 1540 '(superscript 1541 subscript 1542 large-script 1543 bold italic 1544 aligned unaligned))) 1545 (let ([font (loop (cdr style))] 1546 [style (car style)]) 1547 (cond 1548 [(eq? style 'bold) 1549 (extend-font font 1550 (send font get-point-size) 1551 (send font get-style) 1552 'bold 1553 (send font get-hinting))] 1554 [(eq? style 'italic) 1555 (extend-font font 1556 (send font get-point-size) 1557 'italic 1558 (send font get-weight) 1559 (send font get-hinting))] 1560 [(or (eq? style 'aligned) 1561 (eq? style 'unaligned)) 1562 (extend-font font 1563 (send font get-point-size) 1564 (send font get-style) 1565 (send font get-weight) 1566 style)] 1567 [else font]))] 1568 [(and (pair? style) 1569 (memq (car style) '(combine no-combine outline))) 1570 (loop (cdr style))] 1571 [(and (pair? style) 1572 (is-a? (car style) color%)) 1573 (loop (cdr style))] 1574 [else (raise-type-error 'text 1575 "style" 1576 orig-style)]))] 1577 [combine? (let loop ([style orig-style]) 1578 (cond 1579 [(eq? style 'modern) #f] 1580 [(not (pair? style)) #t] 1581 [(eq? (car style) 'combine) #t] 1582 [(eq? (car style) 'no-combine) #f] 1583 [else (loop (cdr style))]))] 1584 [sub? (memq* 'subscript orig-style)] 1585 [sup? (memq* 'superscript orig-style)] 1586 [large-script? (memq* 'large-script orig-style)] 1587 [outline? (memq* 'outline orig-style)] 1588 [color (let loop ([style orig-style]) 1589 (cond 1590 [(not (pair? style)) #f] 1591 [(is-a? (car style) color%) 1592 (resolve-color (car style))] 1593 [else (loop (cdr style))]))]) 1594 (let ([s-font (if (or sub? sup?) 1595 (extend-font font 1596 (floor (* (if large-script? 1597 85/100 1598 6/10) 1599 (send font get-point-size))) 1600 (send font get-style) 1601 (send font get-weight) 1602 (send font get-hinting)) 1603 font)] 1604 [dc (dc-for-text-size)]) 1605 (unless dc 1606 (error 'text "no dc<%> object installed for sizing")) 1607 (let-values ([(w h d s) (with-text-scale 1608 dc 1609 (lambda () 1610 (send dc get-text-extent string s-font combine?)))]) 1611 (define (make-draw adj-x adj-y angle) 1612 (define p 1613 (and outline? 1614 (let ([p (new dc-path%)]) 1615 (send p text-outline 1616 s-font string 0 0 combine?) 1617 (unless (zero? angle) 1618 (send p rotate angle)) 1619 p))) 1620 (lambda (dc x y) 1621 (let ([f (send dc get-font)]) 1622 (define dest-x (adj-x x)) 1623 (define dest-y (adj-y y)) 1624 (cond 1625 [outline? 1626 (define pn (and color (send dc get-pen))) 1627 (when color (send dc set-pen color (send pn get-width) (send pn get-style))) 1628 (send dc draw-path p dest-x dest-y) 1629 (when color (send dc set-pen pn))] 1630 [else 1631 (define fg (and color (send dc get-text-foreground))) 1632 (when color (send dc set-text-foreground color)) 1633 (send dc set-font s-font) 1634 (send dc draw-text string 1635 dest-x dest-y 1636 combine? 0 angle) 1637 (when fg (send dc set-text-foreground fg)) 1638 (send dc set-font f)])))) 1639 (if (or sub? sup?) 1640 (let-values ([(ww wh wd ws) (with-text-scale 1641 dc 1642 (lambda () 1643 (send dc get-text-extent "Wy" font)))]) 1644 (prog-picture (make-draw 1645 (lambda (x) x) 1646 (lambda (y) (if sub? 1647 (+ y 1648 (if large-script? 1649 (+ (* (- wh wd ws) 4/10) 1650 (- ws s)) 1651 (- wh h))) 1652 (+ y 1653 (if large-script? 1654 (* (- wh wd ws) -3/10) 1655 0)))) 1656 0) 1657 w wh (- wh wd) wd)) 1658 (if (zero? angle) 1659 ;; Normal case: no rotation 1660 (prog-picture (make-draw (lambda (x) x) 1661 (lambda (y) y) 1662 0) 1663 w h (- h d) d) 1664 ;; Rotation case. Need to find the bounding box. 1665 ;; Calculate the four corners, relative to top left as origin: 1666 (let* ([tlx 0] 1667 [tly 0] 1668 [ca (cos angle)] 1669 [sa (sin angle)] 1670 [trx (* w ca)] 1671 [try (- (* w sa))] 1672 [brx (+ trx (* h sa))] 1673 [bry (- try (* h ca))] 1674 [blx (* h sa)] 1675 [bly (- (* h ca))] 1676 ;;min-x and min-y must be non-positive, 1677 ;; since tlx and tly are always 0 1678 [min-x (min tlx trx blx brx)] 1679 [min-y (min tly try bly bry)]) 1680 (let ([pw (- (max tlx trx blx brx) min-x)] 1681 [ph (- (max tly try bly bry) min-y)] 1682 [dx (cond 1683 [(and (positive? ca) (positive? sa)) 0] 1684 [(positive? ca) (- (* h sa))] 1685 [(positive? sa) (- (* w ca))] 1686 [else (+ (- (* w ca)) (- (* h sa)))])] 1687 [dy (cond 1688 [(and (positive? ca) (negative? sa)) 0] 1689 [(positive? ca) (* w sa)] 1690 [(negative? sa) (- (* h ca))] 1691 [else (+ (- (* h ca)) (* w sa))])]) 1692 (prog-picture (make-draw (lambda (x) (+ x dx)) 1693 (lambda (y) (+ y dy)) 1694 angle) 1695 pw ph ph 0))))))))) 1696 1697(define caps-text 1698 (case-lambda 1699 [(string) (caps-text string '() 12)] 1700 [(string style) (caps-text string style 12)] 1701 [(string style size) 1702 (let ([strings 1703 (let loop ([l (string->list string)] [this null] [results null] [up? #f]) 1704 (if (null? l) 1705 (reverse (cons (reverse this) results)) 1706 (if (eq? up? (char-upper-case? (car l))) 1707 (loop (cdr l) (cons (car l) this) results up?) 1708 (loop (cdr l) (list (car l)) (cons (reverse this) results) (not up?)))))] 1709 [cap-style 1710 (let loop ([s style]) 1711 (cond 1712 [(pair? s) (cons (car s) (loop (cdr s)))] 1713 [(is-a? s font%) (send the-font-list find-or-create-font 1714 (floor (* 8/10 (send s get-point-size))) 1715 (send s get-family) 1716 (send s get-style) 1717 (send s get-weight) 1718 (send s get-underlined?) 1719 (send s get-smoothing) 1720 (send s get-size-in-pixels?))] 1721 [else s]))] 1722 [cap-size (floor (* 8/10 size))]) 1723 (let ([picts 1724 (let loop ([l strings] [up? #f]) 1725 (if (null? l) 1726 null 1727 (let* ([first-string (list->string (map char-upcase (car l)))] 1728 [first 1729 (not-caps-text first-string 1730 (if up? style cap-style) 1731 (if up? size cap-size) 1732 0)] 1733 [rest (loop (cdr l) (not up?))]) 1734 (if (and up? (pair? (cdr l))) 1735 ;; kern capital followed by non-captial 1736 (let ([plain-first (not-caps-text first-string 1737 cap-style 1738 cap-size 1739 0)] 1740 [together (not-caps-text (string-append 1741 first-string 1742 (list->string (map char-upcase (cadr l)))) 1743 cap-style 1744 cap-size 1745 0)]) 1746 (cons (hbl-append (- (pict-width together) 1747 (+ (pict-width plain-first) 1748 (pict-width (car rest)))) 1749 first 1750 (car rest)) 1751 (cdr rest))) 1752 ;; no kerning needed: 1753 (cons first rest)))))]) 1754 (apply hbl-append 0 picts)))])) 1755 1756(define (linewidth n p) (line-thickness n p)) 1757(define (linestyle n p) 1758 (unless (memq n '(transparent solid xor hilite 1759 dot long-dash short-dash dot-dash 1760 xor-dot xor-long-dash xor-short-dash 1761 xor-dot-dash)) 1762 (raise-type-error 'linestyle "style symbol" n)) 1763 (line-style n p)) 1764 1765(define connect 1766 (case-lambda 1767 [(x1 y1 x2 y2) (connect x1 y1 x2 y2 #f)] 1768 [(x1 y1 x2 y2 arrow?) (~connect 'r +inf.0 x1 y1 x2 y2 arrow?)])) 1769 1770(define ~connect 1771 (case-lambda 1772 [(exact close-enough x1 y1 x2 y2) (~connect exact close-enough x1 y1 x2 y2 #f)] 1773 [(exact close-enough x1 y1 x2 y2 arrow?) 1774 `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,(- x2 x1) ,(- y2 y1) #f)))])) 1775 1776(define (resolve-color c) 1777 (let* ([requested-color (cond 1778 [(is-a? c color%) c] 1779 [(string? c) 1780 (send the-color-database find-color c)] 1781 [(list? c) 1782 (apply make-object color% c)])] 1783 [color (or requested-color 1784 (send the-color-database find-color "BLACK"))]) 1785 (unless requested-color 1786 (eprintf "WARNING: couldn't find color: ~s\n" c)) 1787 color)) 1788 1789 1790(define (render dc h+top l dx dy) 1791 (define b&w? #f) 1792 1793 (with-method ([draw-line (dc draw-line)] 1794 [draw-spline (dc draw-spline)] 1795 [draw-ellipse (dc draw-ellipse)] 1796 [get-pen (dc get-pen)] 1797 [get-brush (dc get-brush)] 1798 [get-text-foreground (dc get-text-foreground)] 1799 [set-pen (dc set-pen)] 1800 [set-brush (dc set-brush)] 1801 [set-text-foreground (dc set-text-foreground)] 1802 [find-or-create-pen (the-pen-list find-or-create-pen)] 1803 [find-or-create-brush (the-brush-list find-or-create-brush)]) 1804 1805 (let loop ([dx dx][dy dy][l l]) 1806 (unless (null? l) 1807 (let ([x (car l)]) 1808 (if (string? x) 1809 (error 'draw-pict "how did a string get here?: ~s" x) 1810 (case (car x) 1811 [(offset) (loop (+ dx (cadr x)) 1812 (+ dy (caddr x)) 1813 (cadddr x))] 1814 [(line vector) 1815 (let ([xs (cadr x)] 1816 [ys (caddr x)] 1817 [len (cadddr x)]) 1818 (let ([mx (if len (abs (if (zero? xs) ys xs)) 1)] 1819 [len (or len 1)]) 1820 (draw-line dx (- h+top dy) 1821 (+ dx (* (/ xs mx) len)) (- h+top (+ dy (* (/ ys mx) len))))))] 1822 [(circle circle*) 1823 (let ([size (cadr x)]) 1824 (draw-ellipse (- dx (/ size 2)) (- h+top dy (/ size 2)) 1825 size size))] 1826 [(oval) 1827 (let ([b (get-brush)] 1828 [rx (- dx (/ (cadr x) 2))] 1829 [ry (- h+top dy (/ (caddr x) 2))]) 1830 (set-brush (find-or-create-brush "BLACK" 'transparent)) 1831 (let ([part (cadddr x)] 1832 [cr (send dc get-clipping-region)] 1833 [set-rect (lambda (l t r b) 1834 (let ([cr (make-object region% dc)]) 1835 (send cr set-rectangle 1836 (+ rx (* l (cadr x))) 1837 (+ ry (* t (caddr x))) 1838 (* (- r l) (cadr x)) 1839 (* (- b t) (caddr x))) 1840 cr))]) 1841 (send dc set-clipping-region 1842 (cond 1843 [(string=? part "[l]") 1844 (set-rect 0 0 0.5 1.0)] 1845 [(string=? part "[tl]") 1846 (set-rect 0 0 0.5 0.5)] 1847 [(string=? part "[tr]") 1848 (set-rect 0.5 0 1.0 0.5)] 1849 [(string=? part "[r]") 1850 (set-rect 0.5 0 1.0 1.0)] 1851 [(string=? part "[bl]") 1852 (set-rect 0 0.5 0.5 1.0)] 1853 [(string=? part "[br]") 1854 (set-rect 0.5 0.5 1.0 1.0)] 1855 [else cr])) 1856 (send dc draw-rounded-rectangle 1857 rx ry 1858 (cadr x) (caddr x) 1859 (if (string=? part "") -0.2 -0.5)) 1860 (send dc set-clipping-region cr) 1861 (set-brush b)))] 1862 [(bezier) 1863 (draw-spline (+ dx (list-ref x 1)) 1864 (- h+top (+ dy (list-ref x 2))) 1865 (+ dx (list-ref x 3)) 1866 (- h+top (+ dy (list-ref x 4))) 1867 (+ dx (list-ref x 5)) 1868 (- h+top (+ dy (list-ref x 6))))] 1869 [(with-color) 1870 (if b&w? 1871 (loop dx dy (caddr x)) 1872 (let ([p (get-pen)] 1873 [b (get-brush)] 1874 [fg (get-text-foreground)]) 1875 (let ([color (resolve-color (cadr x))]) 1876 (set-pen (find-or-create-pen color 1877 (send p get-width) (send p get-style) 1878 (send p get-cap) (send p get-join))) 1879 (set-brush (find-or-create-brush color 'solid)) 1880 (set-text-foreground color)) 1881 (loop dx dy (caddr x)) 1882 (set-pen p) 1883 (set-brush b) 1884 (set-text-foreground fg)))] 1885 [(with-thickness) 1886 (let ([p (get-pen)]) 1887 (set-pen (find-or-create-pen (send p get-color) 1888 (if (number? (cadr x)) 1889 (cadr x) 1890 (case (cadr x) 1891 [(thicklines) 1] 1892 [(thinlines) 0] 1893 [else (send p get-width)])) 1894 (if (number? (cadr x)) 1895 (send p get-style) 1896 (case (cadr x) 1897 [(#f) 'transparent] 1898 [(thicklines thinlines) (send p get-style)] 1899 [else (cadr x)])) 1900 (send p get-cap) 1901 (send p get-join))) 1902 (loop dx dy (caddr x)) 1903 (set-pen p))] 1904 [(prog) 1905 ((cadr x) dc dx (- h+top dy (caddr x)))] 1906 [else (error 'render "unknown command: ~a\n" x)]))) 1907 (loop dx dy (cdr l)))))) 1908 1909(define (make-pict-drawer p) 1910 (let ([cmds (pict->command-list p)]) 1911 (lambda (dc dx dy) 1912 (render dc (+ (pict-height p) dy) 1913 cmds 1914 dx 0)))) 1915 1916(define (draw-pict p dc dx dy) 1917 ((make-pict-drawer p) dc dx dy)) 1918 1919(define (convert-pict p format default #:pad? [pad? #t]) 1920 (cond 1921 [(member format '(pdf-bytes+bounds8 eps-bytes+bounds8 1922 png-bytes+bounds8 png@2x-bytes+bounds8 1923 svg-bytes+bounds8)) 1924 (define xscale (box 1)) 1925 (define yscale (box 1)) 1926 (case format 1927 [(pdf-bytes+bounds8 eps-bytes+bounds8) 1928 (send (current-ps-setup) get-scaling xscale yscale)]) 1929 (define-values (pad-l pad-t pad-r pad-b) 1930 (if pad? 1931 (apply values (convert-bounds-padding)) 1932 (values 0 0 0 0))) 1933 (define pad-p (inset p pad-l pad-t pad-r pad-b)) 1934 (list (convert-pict/bytes pad-p 1935 (case format 1936 [(pdf-bytes+bounds8) 'pdf-bytes] 1937 [(eps-bytes+bounds8) 'eps-bytes] 1938 [(png-bytes+bounds8) 'png-bytes] 1939 [(png@2x-bytes+bounds8) 'png@2x-bytes] 1940 [(svg-bytes+bounds8) 'svg-bytes] 1941 [else (error "internal error" format)]) 1942 default) 1943 (* (unbox xscale) (pict-width pad-p)) 1944 (* (unbox yscale) (pict-height pad-p)) 1945 (* (unbox yscale) (pict-descent pad-p)) 1946 0 1947 (* (unbox xscale) pad-l) 1948 (* (unbox yscale) pad-t) 1949 (* (unbox xscale) pad-r) 1950 (* (unbox yscale) pad-b))] 1951 [(member format '(pdf-bytes+bounds eps-bytes+bounds 1952 png-bytes+bounds 1953 png@2x-bytes+bounds 1954 svg-bytes+bounds)) 1955 (take (convert-pict p 1956 (case format 1957 [(pdf-bytes+bounds) 'pdf-bytes+bounds8] 1958 [(eps-bytes+bounds) 'eps-bytes+bounds8] 1959 [(png-bytes+bounds) 'png-bytes+bounds8] 1960 [(png@2x-bytes+bounds) 'png@2x-bytes+bounds8] 1961 [(svg-bytes+bounds) 'svg-bytes+bounds8] 1962 [else (error "internal error" format)]) 1963 default 1964 #:pad? #f) 1965 5)] 1966 [else 1967 (convert-pict/bytes p format default)])) 1968 1969(define (convert-pict/bytes p format default) 1970 (case format 1971 [(png-bytes png@2x-bytes) 1972 (let* ([bm (make-bitmap 1973 (max 1 (inexact->exact (ceiling (pict-width p)))) 1974 (max 1 (inexact->exact (ceiling (pict-height p)))) 1975 #:backing-scale (if (eq? format 'png@2x-bytes) 2 1))] 1976 [dc (make-object bitmap-dc% bm)]) 1977 (send dc set-smoothing 'aligned) 1978 (draw-pict p dc 0 0) 1979 (send dc set-bitmap #f) 1980 (let ([s (open-output-bytes)]) 1981 (send bm save-file s 'png #:unscaled? #t) 1982 (get-output-bytes s)))] 1983 [(eps-bytes pdf-bytes) 1984 (let ([s (open-output-bytes)] 1985 [xs (box 1)] 1986 [ys (box 1)]) 1987 (send (current-ps-setup) get-scaling xs ys) 1988 (let ([dc (new (if (equal? format 'eps-bytes) post-script-dc% pdf-dc%) 1989 [interactive #f] 1990 [as-eps #t] 1991 [width (* (pict-width p) (unbox xs))] 1992 [height (* (pict-height p) (unbox ys))] 1993 [output s])]) 1994 (send dc set-smoothing 'smoothed) 1995 (send dc start-doc "pict") 1996 (send dc start-page) 1997 (draw-pict p dc 0 0) 1998 (send dc end-page) 1999 (send dc end-doc)) 2000 (get-output-bytes s))] 2001 [(svg-bytes) 2002 (let ([s (open-output-bytes)]) 2003 (define dc (new svg-dc% 2004 [width (pict-width p)] 2005 [height (pict-height p)] 2006 [output s])) 2007 (send dc set-smoothing 'smoothed) 2008 (send dc start-doc "Generating svg") 2009 (send dc start-page) 2010 (draw-pict p dc 0 0) 2011 (send dc end-page) 2012 (send dc end-doc) 2013 (regexp-replace "width=\"([0-9.]*pt)\" height=\"([0-9.]*pt)\"" 2014 (get-output-bytes s) 2015 (λ (all w h) 2016 (define (rem x) (bytes->string/utf-8 (regexp-replace "pt" x ""))) 2017 (string->bytes/utf-8 2018 (string-append "width=\"" (rem w) "\" height=\"" (rem h) "\"")))))] 2019 [else default])) 2020 2021(define (convert-pict-to-vector p) 2022 (define dc (new record-dc% 2023 [width (pict-width p)] 2024 [height (pict-height p)])) 2025 (draw-pict p dc 0 0) 2026 (vector (send dc get-recorded-datum) 2027 (pict-width p) 2028 (pict-height p) 2029 (pict-ascent p) 2030 (pict-descent p))) 2031 2032(define (deserialize-pict datum w h d a) 2033 (define draw (recorded-datum->procedure datum)) 2034 (make-pict `(prog ,(lambda (dc x y) 2035 (define t (send dc get-transformation)) 2036 (send dc translate x y) 2037 (draw dc) 2038 (send dc set-transformation t)) 2039 ,h) 2040 w h d a 2041 null 2042 #f 2043 #f)) 2044 2045(define pict-deserialize-info 2046 (make-deserialize-info deserialize-pict 2047 (lambda () (error "no cycles")))) 2048