#lang scheme/gui (require "unsafe-draw.rkt") (define manual-chinese? #f) (when manual-chinese? (send the-font-name-directory set-post-script-name (send the-font-name-directory find-or-create-font-id "MOESung-Regular" 'default) 'normal 'normal "MOESung-Regular")) (define sys-path (lambda (f) (build-path (collection-path "icons") f))) (define local-path (let ([d (current-load-relative-directory)]) (lambda (f) (build-path d f)))) (define (get-icon) (make-object bitmap% (sys-path "mred.xbm") 'xbm)) (define get-plt (let ([i #f]) (lambda () (unless i (set! i (make-object bitmap% (sys-path "plt.gif")))) i))) (define get-rotated (let ([i #f]) (lambda () (unless i (set! i (let* ([icon (get-icon)] [w (send icon get-width)] [h (send icon get-height)]) (let ([bm (make-object bitmap% w h #t)]) (let ([src (make-object bitmap-dc% icon)] [dest (make-object bitmap-dc% bm)] [c (make-object color%)]) (let loop ([i 0]) (unless (= i w) (let loop ([j 0]) (unless (= j h) (send src get-pixel i j c) (send dest set-pixel i (- h j 1) c) (loop (add1 j)))) (loop (add1 i)))) (send src set-bitmap #f) (send dest set-bitmap #f) bm))))) i))) (define (show-instructions file) (letrec ([f (make-object frame% (path->string file) #f 400 400)] [print (make-object button% "Print" f (lambda (b ev) (send e print)))] [c (make-object editor-canvas% f)] [e (make-object text%)]) (send e load-file file) (send e lock #t) (send c set-editor e) (send f show #t))) (define star ;; uses pairs instead of point%s (list (cons 30 0) (cons 48 60) (cons 0 20) (cons 60 20) (cons 12 60))) (define octagon (list (make-object point% 60 60) (make-object point% 120 60) (make-object point% 180 120) (make-object point% 180 180) (make-object point% 120 240) (make-object point% 60 240) (make-object point% 0 180) (make-object point% 0 120) (make-object point% 60 60))) (define (get-b&w-light-stipple) (make-object bitmap% (list->bytes '(#x88 0 #x22 0 #x88 0 #x22 0)) 8 8)) (define (get-b&w-half-stipple) (make-object bitmap% (list->bytes '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33)) 8 8)) (define lambda-path (let () (define left-lambda-path (let ([p (new dc-path%)]) (send p move-to 148 670) ;; top corner (send p line-to 156.5 654) ;; left edge spline (send p curve-to 197.5 665 225 672 240 653) (send p curve-to 275.06 608.59 282.5 573 291.5 528) (send p curve-to 296.12 504.92 294.11 490.62 288.96 470) (send p curve-to 276.34 419.46 254.18 382.39 228.5 339) (send p curve-to 193.21 279.37 159.68 208.41 120.5 150) (send p line-to 130 142) p)) (define bottom-lambda-path (let ([p (new dc-path%)]) (send p move-to 130 142) ;; bottom left foot (send p line-to 183.5 150) ;; bottom middle spline (send p curve-to 203.5 197 225.91 248.79 246 294) (send p curve-to 262 330 273.5 366 291.5 402) (send p curve-to 296.01 411.02 313 456 324 440) (send p curve-to 333.89 425.61 346 400 353 382) (send p curve-to 372.28 332.42 390.57 284.39 409 237) (send p curve-to 423 201 431.5 174 444.5 141) ;; bottom right foot (send p line-to 460 134) (send p line-to 524 169) p)) (define right-lambda-path (let ([p (new dc-path%)]) (send p move-to 148 670) ;; right edge spline (send p curve-to 187.21 683.31 228.21 699.77 270 694) (send p curve-to 323.6 686.6 345.23 610.92 359 563) (send p curve-to 373.75 511.68 395.5 470 413 420) (send p curve-to 441.56 338.4 489.5 258 525.5 177) (send p line-to 524 169) (send p reverse) p)) (let ([p (new dc-path%)]) (send p append left-lambda-path) (send p append bottom-lambda-path) (send p append right-lambda-path) (send p translate -5 -86) (send p scale 1 -1) (send p translate 0 630) (send p scale 0.5 0.5) p))) (define fancy-path (let ([p (new dc-path%)] [p2 (new dc-path%)]) (send p2 move-to 10 80) (send p2 line-to 80 80) (send p2 line-to 80 10) (send p2 line-to 10 10) (send p2 close) (send p move-to 1 1) (send p line-to 90 1) (send p line-to 90 90) (send p line-to 1 90) (send p close) (send p append p2) (send p arc 50 50 100 120 0 (* pi 1/2) #f) p)) (define square-bm (let* ([bm (make-object bitmap% 10 10)] [dc (make-object bitmap-dc% bm)]) (send dc clear) (send dc set-brush "white" 'transparent) (send dc set-pen "black" 1 'solid) (send dc draw-rectangle 0 0 10 10) (send dc set-bitmap #f) bm)) (define (show-error . args) (with-handlers ([exn? (lambda (exn) (printf "~a\n" (exn-message exn)))]) (apply error args))) (define DRAW-WIDTH 550) (define DRAW-HEIGHT 375) (let* ([f (make-object frame% "Graphics Test" #f 600 550)] [vp (make-object vertical-panel% f)] [hp0 (make-object horizontal-panel% vp)] [hp (make-object horizontal-panel% vp)] [hp3 (make-object horizontal-panel% vp)] [hp2 hp] [hp2.5 hp0] [hp4 (new horizontal-panel% [parent vp] [stretchable-height #f])] [bb (make-object bitmap% (sys-path "bb.gif") 'gif)] [return (let* ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)] [dc (make-object bitmap-dc% bm)]) (send dc draw-line 0 3 20 3) (send dc set-bitmap #f) bm)] [clock-start #f] [clock-end #f] [clock-clip? #f] [do-clock #f] [use-bitmap? #f] [platform-bitmap? #f] [use-record? #f] [serialize-record? #f] [use-bad? #f] [depth-one? #f] [cyan? #f] [multi-page? #f] [smoothing 'unsmoothed] [save-filename #f] [save-file-format #f] [clip 'none] [current-alpha 1.0] [current-c-alpha 1.0] [current-rotation 0.0] [current-skew? #f]) (send hp0 stretchable-height #f) (send hp stretchable-height #f) (send hp2.5 stretchable-height #f) (send hp3 stretchable-height #f) (make-object button% "What Should I See?" hp0 (lambda (b e) (show-instructions (local-path "draw-info.txt")))) (let ([canvas (make-object (class canvas% (init parent) (inherit get-dc refresh init-auto-scrollbars) (define no-bitmaps? #f) (define no-stipples? #f) (define pixel-copy? #f) (define kern? #f) (define clip-pre-scale? #f) (define c-clip? #f) (define mask-ex-mode 'mred) (define xscale 1) (define yscale 1) (define offset 0) (define c-xscale 1) (define c-yscale 1) (define c-offset 0) (public* [set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (refresh))] [set-stipples (lambda (on?) (set! no-stipples? (not on?)) (refresh))] [set-pixel-copy (lambda (on?) (set! pixel-copy? on?) (refresh))] [set-kern (lambda (on?) (set! kern? on?) (refresh))] [set-clip-pre-scale (lambda (on?) (set! clip-pre-scale? on?) (refresh))] [set-canvas-clip (lambda (on?) (set! c-clip? on?) (refresh))] [set-mask-ex-mode (lambda (mode) (set! mask-ex-mode mode) (refresh))] [set-canvas-scale (lambda (xs ys) (set! c-xscale xs) (set! c-yscale ys) (refresh))] [set-scale (lambda (xs ys) (set! xscale xs) (set! yscale ys) (refresh))] [set-offset (lambda (o) (set! offset o) (refresh))] [set-canvas-offset (lambda (o) (set! c-offset o) (refresh))]) (override* [on-paint (case-lambda [() (time (on-paint #f))] [(kind) (let* ([can-dc (get-dc)] [pen0s (make-object pen% "BLACK" 0 'solid)] [pen1s (make-object pen% "BLACK" 1 'solid)] [pen2s (make-object pen% "BLACK" 2 'solid)] [pen0t (make-object pen% "BLACK" 0 'transparent)] [pen1t (make-object pen% "BLACK" 1 'transparent)] [pen2t (make-object pen% "BLACK" 2 'transparent)] [pen0x (make-object pen% "BLACK" 0 'xor)] [pen1x (make-object pen% "BLACK" 1 'xor)] [pen2x (make-object pen% "BLACK" 2 'xor)] [brushs (make-object brush% "BLACK" 'solid)] [brusht (make-object brush% "BLACK" 'transparent)] [brushb (make-object brush% "BLUE" 'solid)] [mem-dc (if use-bitmap? (make-object bitmap-dc%) #f)] [bm (if use-bitmap? (if use-bad? (make-object bitmap% "no such file") (let ([w (ceiling (* xscale DRAW-WIDTH))] [h (ceiling (* yscale DRAW-HEIGHT))]) (if platform-bitmap? (make-platform-bitmap w h) (make-object bitmap% w h depth-one?)))) #f)] [draw-series (lambda (dc pens pent penx size x y flevel last?) (let* ([ofont (send dc get-font)] [otfg (send dc get-text-foreground)] [otbg (send dc get-text-background)] [obm (send dc get-text-mode)]) (when (positive? flevel) (send dc set-font (make-object font% 10 'decorative 'normal (if (> flevel 1) 'bold 'normal) #t))) (send dc set-pen pens) (send dc set-brush brusht) ; Text should overlay this line (except for 2x2) (send dc draw-line (+ x 3) (+ y 12) (+ x 40) (+ y 12)) (send dc set-text-background (make-object color% "YELLOW")) (when (= flevel 2) (send dc set-text-foreground (make-object color% "RED")) (send dc set-text-mode 'solid)) (send dc draw-text (string-append size " P\uE9n") ; \uE9 is e with ' (+ x 5) (+ y 8)) (send dc set-font ofont) (when (= flevel 2) (send dc set-text-foreground otfg) (send dc set-text-mode obm)) (send dc set-text-background otbg) (send dc draw-line (+ x 5) (+ y 27) (+ x 10) (+ 27 y)) (send dc draw-rectangle (+ x 5) (+ y 30) 5 5) (send dc draw-line (+ x 12) (+ y 30) (+ x 12) (+ y 35)) (send dc draw-line (+ x 5) (+ y 40) (+ x 10) (+ 40 y)) (send dc draw-rectangle (+ x 5) (+ y 41) 5 5) (send dc draw-line (+ x 10) (+ y 41) (+ x 10) (+ 46 y)) (send dc draw-line (+ x 15) (+ y 25) (+ x 20) (+ 25 y)) (send dc draw-line (+ x 20) (+ y 30) (+ x 20) (+ 25 y)) (send dc draw-line (+ x 30) (+ y 25) (+ x 25) (+ 25 y)) (send dc draw-line (+ x 25) (+ y 30) (+ x 25) (+ 25 y)) (send dc draw-line (+ x 35) (+ y 30) (+ x 40) (+ 30 y)) (send dc draw-line (+ x 40) (+ y 25) (+ x 40) (+ 30 y)) (send dc draw-line (+ x 50) (+ y 30) (+ x 45) (+ 30 y)) (send dc draw-line (+ x 45) (+ y 25) (+ x 45) (+ 30 y)) ; Check line thickness with "X" (send dc draw-line (+ x 20) (+ y 45) (+ x 40) (+ 39 y)) (send dc draw-line (+ x 20) (+ y 39) (+ x 40) (+ 45 y)) (send dc draw-rectangle (+ x 5) (+ y 50) 10 10) (send dc draw-rounded-rectangle (+ x 5) (+ y 65) 10 10 3) (send dc draw-ellipse (+ x 5) (+ y 80) 10 10) (send dc set-brush brushs) (send dc draw-rectangle (+ x 17) (+ y 50) 10 10) (send dc draw-rounded-rectangle (+ x 17) (+ y 65) 10 10 3) (send dc draw-ellipse (+ x 17) (+ y 80) 10 10) (send dc set-pen pent) (send dc draw-rectangle (+ x 29) (+ y 50) 10 10) (send dc draw-rounded-rectangle (+ x 29) (+ y 65) 10 10 3) (send dc draw-ellipse (+ x 29) (+ y 80) 10 10) (send dc set-pen penx) (send dc draw-rectangle (+ x 41) (+ y 50) 10 10) (send dc draw-rounded-rectangle (+ x 41) (+ y 65) 10 10 3) (send dc draw-ellipse (+ x 41) (+ y 80) 10 10) (send dc set-pen pens) (send dc draw-rectangle (+ x 17) (+ y 95) 10 10) ; (send dc set-logical-function 'clear) (send dc draw-rectangle (+ x 18) (+ y 96) 8 8) ; (send dc set-logical-function 'copy) (send dc draw-rectangle (+ x 29) (+ y 95) 10 10) ; (send dc set-logical-function 'clear) (send dc set-pen pent) (send dc draw-rectangle (+ x 30) (+ y 96) 8 8) (send dc set-pen pens) (send dc draw-rectangle (+ x 5) (+ y 95) 10 10) ; (send dc set-logical-function 'xor) (send dc draw-rectangle (+ x 5) (+ y 95) 10 10) ; (send dc set-logical-function 'copy) (send dc draw-line (+ x 5) (+ y 110) (+ x 8) (+ y 110)) (send dc draw-line (+ x 8) (+ y 110) (+ x 11) (+ y 113)) (send dc draw-line (+ x 11) (+ y 113) (+ x 11) (+ y 116)) (send dc draw-line (+ x 11) (+ y 116) (+ x 8) (+ y 119)) (send dc draw-line (+ x 8) (+ y 119) (+ x 5) (+ y 119)) (send dc draw-line (+ x 5) (+ y 119) (+ x 2) (+ y 116)) (send dc draw-line (+ x 2) (+ y 116) (+ x 2) (+ y 113)) (send dc draw-line (+ x 2) (+ y 113) (+ x 5) (+ y 110)) (send dc draw-lines (list (make-object point% 5 95) (make-object point% 8 95) (make-object point% 11 98) (make-object point% 11 101) (make-object point% 8 104) (make-object point% 5 104) (make-object point% 2 101) (make-object point% 2 98) (make-object point% 5 95)) (+ x 12) (+ y 15)) (send dc draw-point (+ x 35) (+ y 115)) (send dc draw-line (+ x 35) (+ y 120) (+ x 35) (+ y 120)) (send dc draw-line (+ x 5) (+ y 125) (+ x 10) (+ y 125)) (send dc draw-line (+ x 11) (+ y 125) (+ x 16) (+ y 125)) (send dc set-brush brusht) (send dc draw-arc (+ x 5) (+ y 135) 30 40 0 (/ pi 2)) (send dc draw-arc (+ x 5) (+ y 135) 30 40 (/ pi 2) pi) (send dc set-brush brushs) (send dc draw-arc (+ x 45) (+ y 135) 30 40 (/ pi 2) pi) (send dc set-brush brusht) (when last? (let ([p (send dc get-pen)]) (send dc set-pen (make-object pen% "BLACK" 1 'xor)) (send dc draw-polygon octagon) (send dc set-pen p)) (when clock-start (let ([b (send dc get-brush)]) (send dc set-brush (make-object brush% "ORANGE" 'solid)) (send dc draw-arc 0. 60. 180. 180. clock-start clock-end) (send dc set-brush b)))) (when last? (let ([op (send dc get-pen)]) ; Splines (define (draw-ess dx dy) (send dc draw-spline (+ dx 200) (+ dy 10) (+ dx 218) (+ dy 12) (+ dx 220) (+ dy 20)) (send dc draw-spline (+ dx 220) (+ dy 20) (+ dx 222) (+ dy 28) (+ dx 240) (+ dy 30))) (send dc set-pen pen0s) (draw-ess 0 0) (send dc set-pen (make-object pen% "RED" 0 'solid)) (draw-ess -2 2) ; Polygons: odd-even vs. winding (let ([polygon (list (make-object point% 12 0) (make-object point% 40 0) (make-object point% 40 28) (make-object point% 0 28) (make-object point% 0 12) (make-object point% 28 12) (make-object point% 28 40) (make-object point% 12 40) (make-object point% 12 0))] [ob (send dc get-brush)] [op (send dc get-pen)]) (send dc set-pen pen1s) (send dc set-brush (make-object brush% "BLUE" 'solid)) (send dc draw-polygon polygon 200 40 'odd-even) (send dc draw-polygon polygon 200 90 'winding) (send dc set-pen op) (send dc set-brush ob)) ; Brush patterns: (let ([pat-list (list 'bdiagonal-hatch 'crossdiag-hatch 'fdiagonal-hatch 'cross-hatch 'horizontal-hatch 'vertical-hatch)] [b (make-object brush% "BLACK" 'solid)] [ob (send dc get-brush)] [obg (send dc get-background)] [blue (make-object color% "BLUE")]) (let loop ([x 245][y 10][l pat-list]) (unless (null? l) (send b set-color "BLACK") (send b set-style (car l)) (send dc set-brush b) (send dc draw-rectangle x y 20 20) (send dc set-brush ob) (send b set-color "GREEN") (send dc set-brush b) (send dc draw-rectangle (+ x 25) y 20 20) (send dc set-background blue) (send dc draw-rectangle (+ x 50) y 20 20) (send dc set-background obg) (send dc set-brush ob) (loop x (+ y 25) (cdr l)))) (send b set-style 'panel) (send b set-color (get-panel-background)) (send dc set-brush b) (send dc draw-rectangle 320 10 20 20) (send dc draw-ellipse 320 35 20 20) (send dc draw-arc 320 60 20 20 0 3.14) (send dc draw-rounded-rectangle 320 85 20 20 2) (send dc set-brush ob)) (send dc set-pen op)) ; Thick-line centering: (let ([thick (make-object pen% "GREEN" 5 'solid)]) (define (draw-lines) (send dc draw-line 360 10 400 50) (send dc draw-line 360 50 400 10) (send dc draw-line 360 80 400 80) (send dc draw-line 380 60 380 100) (send dc draw-line 360 120 400 140) (send dc draw-line 370 110 390 150)) (let ([op (send dc get-pen)]) (send dc set-pen thick) (draw-lines) (send dc set-pen pen0s) (draw-lines) (send dc set-pen op))) ; B&W 8x8 stipple: (unless no-bitmaps? (let ([bml (get-b&w-light-stipple)] [bmh (get-b&w-half-stipple)] [orig-b (send dc get-brush)] [orig-pen (send dc get-pen)]) (send dc set-brush brusht) (send dc set-pen pen1s) (send dc draw-rectangle 244 164 18 18) (send dc draw-bitmap bml 245 165) (send dc draw-bitmap bml 245 173) (send dc draw-bitmap bml 253 165) (send dc draw-bitmap bml 253 173) (let ([p (make-object pen% "RED" 1 'solid)]) (send p set-stipple bmh) (send dc set-pen p) (send dc draw-rectangle 270 164 18 18)) (send dc set-brush orig-b) (send dc set-pen orig-pen)))) (unless no-bitmaps? (let ([obg (send dc get-background)] [tan (make-object color% "TAN")]) (send dc set-background tan) (let* ([bits #"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789/+"] [bm (make-object bitmap% bits 64 8)]) (send dc draw-bitmap bm 306 164 'opaque)) (let* ([bits #"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567"] [bm (make-object bitmap% bits 48 10)]) (send dc draw-bitmap bm 306 184 'opaque)) (send dc set-background obg))) (when last? ; Test get-text-extent (let ([save-pen (send dc get-pen)] [save-fnt (send dc get-font)]) (send dc set-pen (make-object pen% "YELLOW" 1 'solid)) (let loop ([fam '(default default modern modern decorative roman)] [stl '(normal slant slant italic normal normal)] [wgt '(normal bold normal normal bold normal)] [sze '(12 12 12 12 12 32)] [x 244] [y 210] [chinese? #t]) (unless (null? fam) (let ([fnt (make-object font% (car sze) (car fam) (car stl) (car wgt))] [s "AvgflfiMh"]) (send dc set-font fnt) (send dc draw-text s x y kern?) (send dc set-font save-fnt) (let-values ([(w h d a) (send dc get-text-extent s fnt kern?)]) (send dc draw-rectangle x y w h) (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d))) (when chinese? (let ([s "\u7238"] [x (+ x (* 1.5 w))] [cfnt (if (and (dc . is-a? . post-script-dc%) manual-chinese?) (make-object font% 12 "MOESung-Regular" 'default) fnt)]) (send dc set-font cfnt) (send dc draw-text s x y kern?) (send dc set-font fnt) (let-values ([(w h d a) (send dc get-text-extent s cfnt kern?)]) (send dc draw-rectangle x y w h) (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d))) ;; Mathematical "A" (beyond UCS-2) (let ([s "\U1D670"] [x (+ x (* 1.5 w))]) (send dc set-font fnt) (send dc draw-text s x y kern?) (send dc set-font fnt) (let-values ([(w h d a) (send dc get-text-extent s cfnt kern?)]) (send dc draw-rectangle x y w h) (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d)))))))) (loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h) #f))))) (send dc set-pen save-pen))) ;; Text paths: (let ([p (make-object dc-path%)] [old-pen (send dc get-pen)] [old-brush (send dc get-brush)]) (send p text-outline (make-font #:size 32) "A8" 360 190) (send dc set-pen "black" 1 'solid) (send dc set-brush "pink" 'solid) (send dc draw-path p) (send dc set-pen old-pen) (send dc set-brush old-brush)) ; Bitmap copying: (when (and (not no-bitmaps?) last?) (let ([x 5] [y 165]) (let ([bg (send dc get-background)] [mred-icon (get-icon)]) (send dc set-background "YELLOW") (case mask-ex-mode [(plt plt-mask plt^plt mred^plt) (let* ([plt (get-plt)] [ww (send mred-icon get-width)] [hh (send mred-icon get-height)] [tmp-bm (make-object bitmap% ww hh #f)] [tmp-dc (make-object bitmap-dc% tmp-bm)] [mask-bm tmp-bm]) (send tmp-dc draw-bitmap plt (/ (- (send mred-icon get-width) (send plt get-width)) 2) (/ (- (send mred-icon get-height) (send plt get-height)) 2)) (when (memq mask-ex-mode '(plt^plt mred^plt)) ;; Convert to grayscale (let ([s (make-bytes (* 4 ww hh))]) (send tmp-bm get-argb-pixels 0 0 ww hh s) (for* ([i (in-range 0 ww)] [j (in-range 0 hh)]) (let* ([p (* 4 (+ (* j ww) i))] [v (quotient (+ (bytes-ref s (+ p 1)) (bytes-ref s (+ p 2)) (bytes-ref s (+ p 3))) 3)]) (bytes-set! s (+ p 1) v) (bytes-set! s (+ p 2) v) (bytes-set! s (+ p 3) v))) (set! mask-bm (make-object bitmap% ww hh #f)) (send tmp-dc set-bitmap mask-bm) (send tmp-dc set-argb-pixels 0 0 ww hh s))) (if (eq? mask-ex-mode 'mred^plt) (send dc draw-bitmap mred-icon x y 'solid (send the-color-database find-color "BLACK") mask-bm) (send dc draw-bitmap tmp-bm x y 'solid (send the-color-database find-color "BLACK") (cond [(eq? mask-ex-mode 'plt-mask) mred-icon] [(eq? mask-ex-mode 'plt^plt) mask-bm] [else #f]))))] [(mred^mred) (send dc draw-bitmap mred-icon x y 'solid (send the-color-database find-color "BLACK") mred-icon)] [(mred~) (send dc draw-bitmap (get-rotated) x y 'opaque)] [(mred^mred~ opaque-mred^mred~ red-mred^mred~ opaque-red-mred^mred~) (send dc draw-bitmap mred-icon x y (if (memq mask-ex-mode '(opaque-mred^mred~ opaque-red-mred^mred~)) 'opaque 'solid) (send the-color-database find-color (if (memq mask-ex-mode '(red-mred^mred~ opaque-red-mred^mred~)) "RED" "BLACK")) (get-rotated))] [else ;; simple draw (send dc draw-bitmap mred-icon x y 'xor)]) (send dc set-background bg)) (set! x (+ x (send (get-icon) get-width))) (let ([black (send the-color-database find-color "BLACK")] [red (send the-color-database find-color "RED")] [do-one (lambda (bm mode color) (if (send bm ok?) (begin (let ([h (send bm get-height)] [w (send bm get-width)]) (send dc set-pen (make-object pen% "YELLOW" 1 'solid)) (send dc draw-line 3 3 40 40) (send dc draw-bitmap-section bm x y 0 0 w h mode color) (set! x (+ x w 10)))) (printf "bad bitmap\n")))]) ;; BB icon (do-one bb 'solid black) (let ([start x]) ;; First three return icons: (do-one return 'solid black) (do-one return 'solid red) (do-one return 'opaque red) ;; Next three, on a blue background (let ([end x] [b (send dc get-brush)]) (send dc set-brush (make-object brush% "BLUE" 'solid)) (send dc draw-rounded-rectangle (- start 5) (+ y 15) (- end start) 15 -0.2) (send dc set-brush b) (set! x start) (set! y (+ y 18)) (do-one return 'solid black) (do-one return 'solid red) (do-one return 'opaque red) (set! y (- y 18)))) ;; Another BB icon, make sure color has no effect (do-one bb 'solid red) ;; Another return, blacnk on red (let ([bg (send dc get-background)]) (send dc set-background (send the-color-database find-color "BLACK")) (do-one return 'opaque red) (send dc set-background bg)) ;; Return by drawing into color, copying color to monochrome, then ;; monochrome back oonto canvas: (let* ([w (send return get-width)] [h (send return get-height)] [color (make-object bitmap% w h)] [mono (make-object bitmap% w h #t)] [cdc (make-object bitmap-dc% color)] [mdc (make-object bitmap-dc% mono)]) (send cdc clear) (send cdc draw-bitmap return 0 0) (send mdc clear) (send mdc draw-bitmap color 0 0) (send dc draw-bitmap mono (- x w 10) (+ y 18))) (send dc set-pen pens)))) (when (and (not no-stipples?) last?) ; Blue box as background: (send dc set-brush brushb) (send dc draw-rectangle 80 200 125 40) (when (send return ok?) (let ([b (make-object brush% "GREEN" 'solid)]) (send b set-stipple return) (send dc set-brush b) ; First stipple (transparent background) (send dc draw-rectangle 85 205 30 30) (send dc set-brush brushs) (send b set-style 'opaque) (send dc set-brush b) ; Second stipple (opaque) (send dc draw-ellipse 120 205 30 30) (send dc set-brush brushs) (send b set-stipple bb) (send dc set-brush b) ; Third stipple (BB logo) (send dc draw-rectangle 155 205 20 30) (send dc set-brush brushs) (send b set-stipple #f) (send b set-style 'cross-hatch) (send dc set-brush b) ; Green cross hatch (white BG) on blue field (send dc draw-rectangle 180 205 20 20) (send dc set-brush brushs)))) (when (and pixel-copy? last? (not (or kind (eq? dc can-dc)))) (let* ([x 100] [y 170] [x2 245] [y2 188] [w 40] [h 20] [c (make-object color%)] [bm (make-object bitmap% w h depth-one?)] [mdc (make-object bitmap-dc%)]) (send mdc set-bitmap bm) (let iloop ([i 0]) (unless (= i w) (let jloop ([j 0]) (if (= j h) (iloop (add1 i)) (begin (send dc get-pixel (+ i x) (+ j y) c) (send mdc set-pixel i j c) (jloop (add1 j))))))) (send dc draw-bitmap bm x2 y2) (let ([p (send dc get-pen)] [b (send dc get-brush)]) (send dc set-pen (make-object pen% "BLACK" 0 'xor-dot)) (send dc set-brush brusht) (send dc draw-rectangle x y w h) (send dc set-pen p) (send dc set-brush b)))) (let ([styles (list 'solid 'dot 'long-dash 'short-dash 'dot-dash)] [obg (send dc get-background)] [red (make-object color% "RED")]) (let loop ([s styles][y 250]) (unless (null? s) (let ([p (make-object pen% "GREEN" flevel (car s))]) (send dc set-pen p) (send dc draw-line (+ x 5) y (+ x 30) y) (send dc set-background red) (send dc draw-line (+ x 5) (+ 4 y) (+ x 30) (+ y 4)) (send dc set-background obg) (send pens set-style (car s)) (send dc set-pen pens) (send dc draw-line (+ x 30) y (+ x 55) y) (send dc set-background red) (send dc draw-line (+ x 30) (+ y 4) (+ x 55) (+ y 4)) (send dc set-background obg) (send dc set-pen pent) (send pens set-style 'solid) (loop (cdr s) (+ y 8)))))) (when (= flevel 2) (let ([lens '(0 0.25 0.5 0.75 1.0 1.25 1.5 1.75 2.0)]) (let loop ([l lens][x 10]) (unless (null? l) (let ([p (make-object pen% "BLACK" (car l) 'solid)]) (send dc set-pen p) (send dc draw-line x 300 (+ x 19) 300) (send dc set-pen pent) (loop (cdr l) (+ x 20))))))) (when last? (let () (define (pen cap join) (let ([p (make-object pen% "blue" 4 'solid)]) (send p set-cap cap) (send p set-join join) (send dc set-pen p))) (send dc set-brush (make-object brush% "white" 'transparent)) (pen 'projecting 'miter) (send dc draw-lines star 410 10) (send dc draw-polygon star 480 10) (pen 'round 'round) (send dc draw-lines star 410 80) (send dc draw-polygon star 480 80) (pen 'butt 'bevel) (send dc draw-lines star 410 150) (send dc draw-polygon star 480 150)) (send dc set-pen (make-object pen% "green" 3 'solid)) (send dc set-brush (make-object brush% "yellow" 'solid)) (send dc draw-path (let ([p (new dc-path%)]) (send p append fancy-path) (send p scale 0.5 0.5) (send p translate 410 230) p)) (send dc set-pen (make-object pen% "black" 0 'solid)) (send dc set-brush (make-object brush% "red" 'solid)) (send dc draw-path (let ([p (new dc-path%)]) (send p append lambda-path) (send p scale 0.3 0.3) p) 465 230) (send dc draw-path (let ([p (new dc-path%)]) (send p rectangle 10 310 20 20) (send p rounded-rectangle 40 310 20 20 5) (send p ellipse 70 310 20 20) (send p move-to 100 310) (send p lines (list (make-object point% 0 0) (make-object point% 0 20) (make-object point% 20 10)) 100 310) p)) (let ([p (send dc get-pen)]) (send dc set-pen (make-object color% 0 0 0 0.1) 1 'solid) (send dc set-brush (make-object color% 255 0 200 0.5) 'solid) (send dc draw-rectangle 250 320 20 20) (send dc set-brush (make-object color% 0 255 200 0.5) 'solid) (send dc draw-rectangle 260 330 20 20) (send dc set-pen p)) (let ([p (send dc get-pen)]) (send dc set-pen "white" 1 'transparent) (send dc set-brush (new brush% [gradient (make-object linear-gradient% 300 0 380 0 (list (list 0.0 (make-object color% 255 0 0)) (list 0.5 (make-object color% 0 255 0)) (list 1.0 (make-object color% 0 0 255 0.0))))])) (send dc draw-rectangle 300 320 80 20) (send dc set-pen p)) (let ([p (send dc get-pen)]) (send dc set-pen "black" 1 'solid) (send dc set-brush surface-brush) (send dc draw-rectangle 400 320 30 40) (send dc set-pen p)) (let ([p (send dc get-pen)]) (send dc set-pen "white" 1 'transparent) (send dc set-brush (new brush% [gradient (make-object radial-gradient% 360 250 5 365 245 25 (list (list 0.0 (make-object color% 255 0 0)) (list 0.5 (make-object color% 0 255 0)) (list 1.0 (make-object color% 0 0 255 0.0))))])) (send dc draw-rectangle 338 228 44 44) (send dc set-pen p)) (send dc draw-line 130 310 150 310) (send dc draw-line 130 312.5 150 312.5) (send dc draw-line 130 314.3 150 314.3) (send dc draw-line 130 316.7 150 316.7) (let-values ([(xs ys) (send dc get-scale)]) (send dc set-scale (* xs 1.25) (* ys 1.25)) (let ([x (/ 10 1.25)] [y (/ 340 1.25)]) (send dc draw-bitmap square-bm x y) (send dc draw-bitmap square-bm (+ x 10) y) (send dc draw-bitmap square-bm (+ x 20) y) (send dc draw-bitmap square-bm (+ x 30) y)) (send dc set-scale xs ys) (send dc set-pen "black" 0 'solid) (send dc draw-line 10 337 59 337)) (let ([p (send dc get-pen)]) (send dc set-pen "blue" 8 'solid) (send dc draw-rectangle 160 310 20 20) (send dc set-pen "blue" 7 'solid) (send dc draw-rectangle 187 310 20 20) (send dc set-pen p))) (when (and last? (or (and (not (or kind (eq? dc can-dc))) (send mem-dc get-bitmap)) use-record?)) (send can-dc set-origin c-offset c-offset) (send can-dc set-scale c-xscale c-yscale) (send can-dc set-alpha current-c-alpha) (when c-clip? (define r (new region%)) (send r set-rectangle 0 0 200 200) (send can-dc set-clipping-region r)) (if use-record? (if serialize-record? (let () (define-values (i o) (make-pipe)) (write (send dc get-recorded-datum) o) ((recorded-datum->procedure (read i)) can-dc)) ((send dc get-recorded-procedure) can-dc)) (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque)) (send can-dc set-origin 0 0) (send can-dc set-scale 1 1) (send can-dc set-alpha 1.0) (send can-dc set-clipping-region #f))) 'done)]) (send (get-dc) set-scale 1 1) (send (get-dc) set-origin 0 0) (let ([dc (if kind (let ([dc (case kind [(print) (make-object printer-dc%)] [(svg) (let ([fn (put-file)]) (and fn (new svg-dc% [width (* xscale DRAW-WIDTH)] [height (* yscale DRAW-HEIGHT)] [output fn] [exists 'truncate])))] [(ps pdf) (let ([page? (eq? 'yes (message-box "Bounding Box" "Use paper bounding box?" #f '(yes-no)))]) (new (if (eq? kind 'ps) post-script-dc% pdf-dc%) [width (* xscale DRAW-WIDTH)] [height (* yscale DRAW-HEIGHT)] [as-eps (not page?)] [use-paper-bbox page?]))])]) (and (send dc ok?) dc)) (if use-record? (make-object record-dc% (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) (if (and use-bitmap?) (begin (send mem-dc set-bitmap bm) mem-dc) (get-dc))))]) (when dc (send dc start-doc "Draw Test") (send dc start-page) (send dc clear) (send dc set-alpha current-alpha) (send dc set-rotation (- current-rotation)) (send dc set-initial-matrix (if current-skew? (vector 1 0 0.2 1 3 0) (vector 1 0 0 1 0 0))) (if clip-pre-scale? (begin (send dc set-scale 1 1) (send dc set-origin 0 0)) (begin (send dc set-scale xscale yscale) (send dc set-origin offset offset))) (send dc set-smoothing smoothing) (send dc set-background (if cyan? (send the-color-database find-color "CYAN") (send the-color-database find-color "WHITE"))) ;(send dc set-clipping-region #f) (send dc clear) (let ([clip-dc dc]) (if clock-clip? (let ([r (make-object region% clip-dc)]) (send r set-arc 0. 60. 180. 180. clock-start clock-end) (send dc set-clipping-region r)) (let ([mk-poly (lambda (mode) (let ([r (make-object region% clip-dc)]) (send r set-polygon octagon 0 0 mode) r))] [mk-circle (lambda () (let ([r (make-object region% clip-dc)]) (send r set-ellipse 0. 60. 180. 180.) r))] [mk-rect (lambda () (let ([r (make-object region% clip-dc)]) (send r set-rectangle 100 -25 10 400) r))]) (case clip [(none) (void)] [(rect) (send dc set-clipping-rect 100 -25 10 400)] [(rect2) (send dc set-clipping-rect 50 -25 10 400)] [(poly) (send dc set-clipping-region (mk-poly 'odd-even))] [(circle) (send dc set-clipping-region (mk-circle))] [(wedge) (let ([r (make-object region% clip-dc)]) (send r set-arc 0. 60. 180. 180. (* 1/4 pi) (* 3/4 pi)) (send dc set-clipping-region r))] [(lam) (let ([r (make-object region% clip-dc)]) (send r set-path lambda-path) (send dc set-clipping-region r))] [(A) (let ([p (new dc-path%)] [r (make-object region% clip-dc)]) (send p text-outline (make-font #:size 256) "A" 10 10) (send r set-path p) (send dc set-clipping-region r))] [(rect+poly) (let ([r (mk-poly 'winding)]) (send r union (mk-rect)) (send dc set-clipping-region r))] [(rect+circle) (let ([r (mk-circle)]) (send r union (mk-rect)) (send dc set-clipping-region r))] [(poly-rect) (let ([r (mk-poly 'odd-even)]) (send r subtract (mk-rect)) (send dc set-clipping-region r))] [(poly&rect) (let ([r (mk-poly 'odd-even)]) (send r intersect (mk-rect)) (send dc set-clipping-region r))] [(poly^rect) (let ([r (mk-poly 'odd-even)]) (send r xor (mk-rect)) (send dc set-clipping-region r))] [(roundrect) (let ([r (make-object region% clip-dc)]) (send r set-rounded-rectangle 80 200 125 40 -0.25) (send dc set-clipping-region r))] [(empty) (let ([r (make-object region% clip-dc)]) (send dc set-clipping-region r))] [(polka) (let ([c (send dc get-background)]) (send dc set-background (send the-color-database find-color "PURPLE")) (send dc clear) (send dc set-background c)) (let ([r (make-object region% clip-dc)] [w 30] [s 10]) (let xloop ([x 0]) (if (> x 300) (send dc set-clipping-region r) (let yloop ([y 0]) (if (> y 500) (xloop (+ x w s)) (let ([r2 (make-object region% clip-dc)]) (send r2 set-ellipse x y w w) (send r union r2) (yloop (+ y w s)))))))) (send dc clear)])))) (when clip-pre-scale? (send dc set-scale xscale yscale) (send dc set-origin offset offset) (let ([r (send dc get-clipping-region)]) (send dc set-clipping-rect 0 0 20 20) (if r (let ([r2 (make-object region% dc)]) (send r2 set-rectangle 0 0 0 0) (send r xor r2) (send r2 xor r) (send dc set-clipping-region r2)) (send dc set-clipping-region #f)))) (unless clock-clip? (let ([r (send dc get-clipping-region)]) (when r (when (send r get-dc) (unless (eq? (send r is-empty?) (eq? clip 'empty)) (show-error 'draw-text "region `is-empty?' mismatch")))))) (define (mutate-region) (when (and (not clock-clip?) (not (eq? clip 'none))) ;; To be uncooperative, mutate the clipping region: (define r (send dc get-clipping-region)) (define r2 (make-object region% (send r get-dc))) (send r2 union r) (send dc set-clipping-region #f) (send r set-rectangle 0 0 10 10) (send dc set-clipping-region r2))) ;; check default pen/brush: (send dc draw-rectangle 0 0 5 5) (send dc draw-line 0 0 20 6) (send dc set-font (make-object font% 10 'default)) (draw-series dc pen0s pen0t pen0x "0 x 0" 5 0 0 #f) (mutate-region) (draw-series dc pen1s pen1t pen1x "1 x 1" 70 0 1 #f) (draw-series dc pen2s pen2t pen2x "2 x 2" 135 0 2 #t) (unless clock-clip? (let ([r (send dc get-clipping-region)]) (if (eq? clip 'none) (when r (show-error 'draw-test "shouldn't have been a clipping region")) (let*-values ([(x y w h) (send r get-bounding-box)] [(l) (list x y w h)] [(=~) (lambda (x y) (or (not y) (<= (- x 2) y (+ x 2))))]) (unless (andmap =~ l (let ([l (case clip [(rect) '(100. -25. 10. 400.)] [(rect2) '(50. -25. 10. 400.)] [(poly circle poly-rect) '(0. 60. 180. 180.)] [(wedge) '(26. 60. 128. 90.)] [(lam) '(58. 10. 202. 281.)] [(A) '(#f #f #f #f)] [(rect+poly rect+circle poly^rect) '(0. -25. 180. 400.)] [(poly&rect) '(100. 60. 10. 180.)] [(roundrect) '(80. 200. 125. 40.)] [(polka) '(0. 0. 310. 510.)] [(empty) '(0. 0. 0. 0.)])]) (if clip-pre-scale? (list (- (/ (car l) xscale) offset) (- (/ (cadr l) yscale) offset) (- (/ (caddr l) xscale) offset) (- (/ (cadddr l) yscale) offset)) l))) (show-error 'draw-test "clipping region changed badly: ~a" l)))))) (let-values ([(w h) (send dc get-size)]) (unless (cond [kind #t] [use-bad? #t] [use-bitmap? (and (= w (ceiling (* xscale DRAW-WIDTH))) (= h (ceiling (* yscale DRAW-HEIGHT))))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) (show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h (if use-bitmap? (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) (send dc set-clipping-region #f) (send dc end-page) (when (and kind multi-page?) (send dc start-page) (send dc draw-text "Page 2" 0 0) (send dc end-page)) (send dc end-doc))) (when save-filename (send bm save-file save-filename save-file-format) (set! save-filename #f)) 'done)])]) (super-new [parent parent][style '(hscroll vscroll)]) (init-auto-scrollbars (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT) 0 0)) vp)]) (make-object choice% #f '("Canvas" "Pixmap" "Bitmap" "Platform" "Record" "Serialize" "Bad") hp0 (lambda (self event) (set! use-bitmap? (< 0 (send self get-selection))) (set! depth-one? (< 1 (send self get-selection))) (set! platform-bitmap? (= 3 (send self get-selection))) (set! use-record? (<= 4 (send self get-selection) 5)) (set! serialize-record? (= 5 (send self get-selection))) (set! use-bad? (< 5 (send self get-selection))) (send canvas refresh))) (make-object button% "PS" hp (lambda (self event) (send canvas on-paint 'ps))) (make-object button% "PDF" hp (lambda (self event) (send canvas on-paint 'pdf))) (make-object button% "SVG" hp (lambda (self event) (send canvas on-paint 'svg))) (make-object check-box% "Multiple Pages" hp (lambda (self event) (set! multi-page? (send self get-value)))) (make-object button% "Save" hp (lambda (b e) (unless use-bitmap? (error 'save-file "only available for pixmap/bitmap mode")) (let ([f (put-file)]) (when f (let ([format (cond [(regexp-match "[.]xbm$" f) 'xbm] [(regexp-match "[.]xpm$" f) 'xpm] [(regexp-match "[.]jpe?g$" f) 'jpeg] [(regexp-match "[.]png$" f) 'png] [else (error 'save-file "unknown suffix: ~e" f)])]) (set! save-filename f) (set! save-file-format format) (send canvas refresh)))))) (make-object check-box% "Cyan" hp (lambda (self event) (set! cyan? (send self get-value)) (send canvas refresh))) (send (make-object check-box% "Icons" hp2 (lambda (self event) (send canvas set-bitmaps (send self get-value)))) set-value #t) (send (make-object check-box% "Stipples" hp2 (lambda (self event) (send canvas set-stipples (send self get-value)))) set-value #t) (make-object check-box% "Pixset" hp2 (lambda (self event) (send canvas set-pixel-copy (send self get-value)))) (make-object choice% #f '("Unsmoothed" "Smoothed" "Aligned") hp2.5 (lambda (self event) (set! smoothing (list-ref '(unsmoothed smoothed aligned) (send self get-selection))) (send canvas refresh))) (make-object button% "Clock" hp2.5 (lambda (b e) (do-clock #f))) (make-object choice% #f '("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd" "MrEd~ Opaque" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red" "M^M~ Rd Opq" "PLT^PLT") hp2.5 (lambda (self event) (send canvas set-mask-ex-mode (list-ref '(mred plt plt-mask mred^plt mred^mred mred~ mred^mred~ opaque-mred^mred~ red-mred^mred~ opaque-red-mred^mred~ plt^plt) (send self get-selection))))) (make-object check-box% "Kern" hp2.5 (lambda (self event) (send canvas set-kern (send self get-value)))) (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp3 (lambda (self event) (send canvas set-scale (list-ref '(1 2 1/2 1 2) (send self get-selection)) (list-ref '(1 2 1/2 2 1) (send self get-selection))))) (make-object check-box% "+10" hp3 (lambda (self event) (send canvas set-offset (if (send self get-value) 10 0)))) (make-object choice% #f '("Cvs 1" "Cvs *2" "Cvs /2" "Cvs 1,*2" "Cvs *2,1") hp3 (lambda (self event) (send canvas set-canvas-scale (list-ref '(1 2 1/2 1 2) (send self get-selection)) (list-ref '(1 2 1/2 2 1) (send self get-selection))))) (make-object check-box% "Cvs +10" hp3 (lambda (self event) (send canvas set-canvas-offset (if (send self get-value) 10 0)))) (make-object choice% "Clip" '("None" "Rectangle" "Rectangle2" "Octagon" "Circle" "Wedge" "Round Rectangle" "Lambda" "A" "Rectangle + Octagon" "Rectangle + Circle" "Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka" "Empty") hp3 (lambda (self event) (set! clip (list-ref '(none rect rect2 poly circle wedge roundrect lam A rect+poly rect+circle poly-rect poly&rect poly^rect polka empty) (send self get-selection))) (send canvas refresh))) (make-object check-box% "Clip Pre-Scale" hp3 (lambda (self event) (send canvas set-clip-pre-scale (send self get-value)))) (make-object check-box% "Cvs Clip" hp3 (lambda (self event) (send canvas set-canvas-clip (send self get-value)))) (let ([clock (lambda (clip?) (thread (lambda () (set! clock-clip? clip?) (let loop ([c 0][swapped? #f][start 0.][end 0.]) (if (= c 32) (if swapped? (void) (loop 0 #t 0. 0.)) (begin (set! clock-start (if swapped? end start)) (set! clock-end (if swapped? start end)) (send canvas on-paint) (sleep 0.25) (loop (add1 c) swapped? (+ start (/ pi 8)) (+ end (/ pi 16)))))) (set! clock-clip? #f) (set! clock-start #f) (set! clock-end #f) (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) (make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print))) (make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)]) (when c (send (current-ps-setup) copy-from c))))) (make-object slider% "Alpha" 0 10 hp4 (lambda (s e) (let ([a (/ (send s get-value) 10.0)]) (unless (= a current-alpha) (set! current-alpha a) (send canvas refresh)))) 10 '(horizontal plain)) (make-object check-box% "Cvs Fade" hp4 (lambda (c e) (set! current-c-alpha (if (send c get-value) 0.5 1.0)) (send canvas refresh))) (make-object slider% "Rotation" 0 100 hp4 (lambda (s e) (let ([a (* pi 1/4 (/ (send s get-value) 100.0))]) (unless (= a current-rotation) (set! current-rotation a) (send canvas refresh)))) 0 '(horizontal plain)) (make-object check-box% "Skew" hp4 (lambda (c e) (set! current-skew? (send c get-value)) (send canvas refresh))))) (send f show #t))