diff --git a/gui-test/tests/gracket/README b/gui-test/tests/gracket/README index a9259ec4..afc9b87d 100644 --- a/gui-test/tests/gracket/README +++ b/gui-test/tests/gracket/README @@ -5,11 +5,6 @@ button in the top-left for more information. --------------------------------------------------------------------------- -The "draw.rkt" test (use load/cd) tests drawing commands. Click the -"What Should I See?" button for further details. - ---------------------------------------------------------------------------- - The "mem.rkt" test gracket mem.rkt creates a lot of frames and instance of other objects, reporting diff --git a/gui-test/tests/gracket/bitmap-stress.rkt b/gui-test/tests/gracket/bitmap-stress.rkt deleted file mode 100644 index 1089a3ed..00000000 --- a/gui-test/tests/gracket/bitmap-stress.rkt +++ /dev/null @@ -1,47 +0,0 @@ -#lang racket/base -(require racket/class - racket/draw - racket/file) - -;; Check memory-management in the bitmap/PNG/JPEG/etc. library by reading -;; and writing in many threads at the same time. - -(define (check src save-type [read-type 'unknown/alpha]) - (define ts - (for/list ([i (in-range 40)]) - (thread - (lambda() - (for ([i (in-range 10)]) - (define bm (read-bitmap (collection-file-path src "icons"))) - (define t (make-temporary-file)) - (send bm save-file t save-type) - (define bm2 (read-bitmap t read-type)) - (define w (send bm get-width)) - (define h (send bm get-width)) - (define s1 (make-bytes (* w h 4))) - (define s2 (make-bytes (* w h 4))) - (send bm get-argb-pixels 0 0 w h s1) - (send bm2 get-argb-pixels 0 0 w h s2) - (case save-type - [(jpeg) - ;; JPEG is lossy, so use a fuzzy compare: - (define diff (for/sum ([b1 (in-bytes s1)] - [b2 (in-bytes s2)]) - (- b2 b1))) - (unless ((abs diff) . < . (* w h 1)) - (error 'bitmap-stress "mismatch for ~s ~s: ~s ~s ~e" - src save-type - w h diff))] - [else - (unless (equal? s1 s2) - (error 'bitmap-stress "mismatch for ~s ~s" src save-type))]) - (delete-file t)))))) - - (for ([t (in-list ts)]) (sync t))) - -(check "PLT-206.png" 'png) -(check "plt.jpg" 'jpeg) -(check "htdp-icon.gif" 'png 'unknown) -(check "help16x16.xpm" 'png 'unknown) -(check "help16x16.xbm" 'png 'unknown) -(check "help.bmp" 'png 'unknown) diff --git a/gui-test/tests/gracket/blits.rkt b/gui-test/tests/gracket/blits.rkt deleted file mode 100644 index d7d2b903..00000000 --- a/gui-test/tests/gracket/blits.rkt +++ /dev/null @@ -1,93 +0,0 @@ -#lang scheme/gui - -(define ok-frame (make-object frame% "Ok")) -(define ok-panel #f) - -(define (try path mode color bg-color sx sy) - (let ([bm (if (is-a? path bitmap%) - path - (make-object bitmap% path 'unknown/mask))]) - (let ([w (inexact->exact (ceiling (* sx (send bm get-width))))] - [h (inexact->exact (ceiling (* sy (send bm get-height))))]) - (let* ([dest1 (make-object bitmap% w h)] - [dest2 (make-object bitmap% w h)] - [dc1 (make-object bitmap-dc% dest1)] - [dc2 (make-object bitmap-dc% dest2)] - [s1 (make-bytes (* w h 4))] - [s2 (make-bytes (* w h 4))]) - (send dc1 clear) - (send dc2 clear) - (send dc1 set-brush bg-color 'solid) - (send dc1 draw-rectangle 0 0 w h) - (send dc2 set-brush bg-color 'solid) - (send dc2 draw-rectangle 0 0 w h) - (send dc1 set-scale sx sy) - (send dc2 set-scale sx sy) - (send dc1 draw-bitmap bm 0 0 - mode color (send bm get-loaded-mask)) - (send dc2 draw-bitmap bm 0 0 - mode color (send bm get-loaded-mask)) - (send dc1 get-argb-pixels 0 0 w h s1) - (send dc2 get-argb-pixels 0 0 w h s2) - (send dc1 set-bitmap #f) - (send dc2 set-bitmap #f) - (if (bytes=? s1 s2) - (make-object message% dest1 ok-panel) - (let ([f (make-object frame% "Different!")]) - (make-object message% dest1 f) - (make-object message% dest2 f) - (send f show #t))))))) - -(define (self-mask path) - (let ([bm (make-object bitmap% path)]) - (send bm set-loaded-mask bm) - bm)) - -(define (plus-mask path mpath) - (let ([bm (make-object bitmap% path)] - [xmbm (make-object bitmap% mpath)]) - (let* ([w (send bm get-width)] - [h (send bm get-height)] - [mbm (make-object bitmap% w h (= 1 (send xmbm get-depth)))] - [dc (make-object bitmap-dc% mbm)]) - (send dc clear) - (send dc draw-bitmap-section xmbm 0 0 0 0 w h) - (send dc set-bitmap #f) - (send bm set-loaded-mask mbm) - bm))) - -(define targets - (list - ;; (collection-file-path "clock.png" "frtime" "tool") - ;; (self-mask (collection-file-path "clock.png" "frtime" "tool")) - (collection-file-path "foot-up.png" "icons") - (collection-file-path "mred.xbm" "icons") - (self-mask (collection-file-path "mred.xbm" "icons")) - (plus-mask (collection-file-path "mred.xbm" "icons") - (collection-file-path "PLT-206.png" "icons")) - ;; (plus-mask (collection-file-path "clock.png" "frtime" "tool") - ;; (collection-file-path "mred.xbm" "icons")) - (collection-file-path "htdp-icon.gif" "icons") - )) - -(for-each - (lambda (mode) - (for-each (lambda (sx sy) - (set! ok-panel (make-object horizontal-panel% ok-frame)) - (for-each - (lambda (fg) - (for-each (lambda (target) - (try target - mode - fg - (make-object color% "green") - sx sy)) - targets)) - (list (make-object color% "black") - (make-object color% "red")))) - '(1 3/2 1/2) - '(1 1/2 3/2))) - '(solid opaque xor)) - - -(send ok-frame show #t) diff --git a/gui-test/tests/gracket/dc.rktl b/gui-test/tests/gracket/dc.rktl deleted file mode 100644 index b9541346..00000000 --- a/gui-test/tests/gracket/dc.rktl +++ /dev/null @@ -1,869 +0,0 @@ -(load-relative "loadtest.rktl") - -(require racket/gui/base) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; DC Tests ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define mdc (make-object bitmap-dc%)) -(define bm (make-object bitmap% 10 10)) -(define bm2 (make-object bitmap% 10 10)) - -(test #t 'is-color? (send bm is-color?)) - -(define (bad m . args) - (with-handlers ([exn:fail:contract? - (lambda (x) - (test '("ok") - `(send ,m ...) - (regexp-match "ok" (exn-message x))))]) - (send-generic mdc (make-generic (object-interface mdc) m) . args) - (error 'bad-dc "~a shouldn't succeed" `(send ,m ...)))) - -(define (good m . args) - (send-generic mdc (make-generic (object-interface mdc) m) . args)) - -(define (test-all mdc try try-ok) - (try 'erase) - (try 'clear) - (try 'draw-arc 0 0 10 10 0.1 0.2) - (try 'draw-bitmap bm2 0 0) - (try 'draw-bitmap-section bm2 0 0 0 0 5 5) - (try 'draw-ellipse 0 0 10 10) - (try 'draw-line 0 0 10 10) - (try 'draw-lines (list (make-object point% 0 0) (make-object point% 10 10))) - (try 'draw-point 5 5) - (try 'draw-polygon (list (make-object point% 0 0) (make-object point% 10 10) (make-object point% 5 10))) - (try 'draw-rectangle 0 0 10 10) - (try 'draw-rounded-rectangle 0 0 10 10) - (try 'draw-spline 0 0 10 10 5 10) - (try 'draw-text "Hello" 0 0) - - (try 'start-doc "Ok") - (try 'start-page) - (try 'end-page) - (try 'end-doc) - - (try 'get-size) - - (try-ok 'get-background) - (try-ok 'get-brush) - (try-ok 'get-clipping-region) - (try-ok 'get-font) - (try-ok 'get-pen) - (try-ok 'get-text-background) - (try-ok 'get-text-foreground) - (try-ok 'get-text-mode) - (try-ok 'get-alpha) - (try-ok 'get-scale) - (try-ok 'get-origin) - (try-ok 'get-rotation) - - (try-ok 'set-background (make-object color% "Yellow")) - (try-ok 'set-brush (make-object brush% "Yellow" 'solid)) - (try-ok 'set-clipping-rect 0 0 10 10) - (try-ok 'set-clipping-region (make-object region% mdc)) - (try-ok 'set-font (make-object font% 12 'default 'normal 'normal)) - (try-ok 'set-origin 0 0) - (try-ok 'set-pen (make-object pen% "Yellow" 1 'solid)) - (try-ok 'set-scale 2 2) - (try-ok 'set-alpha 0.75) - (try-ok 'set-text-background (make-object color% "Yellow")) - (try-ok 'set-text-foreground (make-object color% "Yellow")) - (try-ok 'set-text-mode 'transparent) - - (try-ok 'get-char-height) - (try-ok 'get-char-width) - - (try 'try-color (make-object color% "Yellow") (make-object color%))) - -(st #f mdc ok?) -(test-all mdc bad good) - -(send mdc set-bitmap bm) - -(test-all mdc - (lambda (m . args) - (send-generic mdc (make-generic (object-interface mdc) m) . args)) - (lambda (m . args) - (send-generic mdc (make-generic (object-interface mdc) m) . args))) - -(send mdc set-bitmap #f) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Get-pixel, set-pixel, get-argb-pixels, etc. - -(require mzlib/etc) - -(define (pixel-tests b&w?) - (begin-with-definitions - - (define bm3 (make-object bitmap% 10 10 b&w?)) - - (define mdc (make-object bitmap-dc% bm3)) - (send mdc clear) - - (define col (make-object color%)) - (define bts (make-bytes 40)) - - (st #f mdc get-pixel 30 4 col) - (st #t mdc get-pixel 3 4 col) - (st 255 col red) - (st 255 col green) - (st 255 col blue) - (stv mdc get-argb-pixels 0 0 2 5 bts) - (test #t 'same-str (equal? (make-bytes 40 255) bts)) - - (send col set 30 40 50) - (send mdc try-color col col) - (send mdc set-pixel 3 4 col) - (when b&w? - (st 0 col red) - (st 0 col green) - (st 0 col blue)) - - (stv mdc get-argb-pixels 2 1 2 5 bts) - (test #t 'same-str (equal? (bytes-append (make-bytes 28 255) - (bytes 255 - (send col red) - (send col green) - (send col blue)) - (make-bytes 8 255)) - bts)) - - (define col2 (make-object color% 130 140 150)) - (send mdc try-color col2 col2) - (let loop ([i 0]) - (unless (= i 10) - (bytes-set! bts (+ 0 (* i 4)) 255) - (bytes-set! bts (+ 1 (* i 4)) (send col2 red)) - (bytes-set! bts (+ 2 (* i 4)) (send col2 green)) - (bytes-set! bts (+ 3 (* i 4)) (send col2 blue)) - (loop (add1 i)))) - (stv mdc set-argb-pixels 5 5 5 2 bts) - (let ([col3 (make-object color%)] - [white (make-object color% 255 255 255)] - [check-col (lambda (what a b) - (test #t `(same red ,what, (send a red) ,(send b red)) (= (send a red) (send b red))) - (test #t `(same green ,what) (= (send a green) (send b green))) - (test #t `(same blue ,what) (= (send a blue) (send b blue))))]) - (let i-loop ([i 0]) - (unless (= i 10) - (let j-loop ([j 0]) - (if (= j 10) - (i-loop (add1 i)) - (begin - (st #t mdc get-pixel i j col3) - (cond - [(and (= i 3) (= j 4)) - (check-col '(3 4) col col3)] - [(and (<= 5 i 9) - (<= 5 j 6)) - (check-col `(,i ,j) col2 col3)] - [else - (check-col `(,i ,j) white col3)]) - (j-loop (add1 j)))))))))) - -(pixel-tests #f) -(pixel-tests #t) - -;; ---------------------------------------- - -;; Extra get-argb-pixels on monochrome text (from PR 8821): - -(let* ((bm (make-object bitmap% 5 5 #t)) - (bm2 (make-object bitmap% 5 5 #t)) - (dc (new bitmap-dc% (bitmap bm))) - (pt (lambda (x y) (make-object point% x y))) - (bs (make-bytes 100)) - (bs2 (make-bytes 100))) - (send dc clear) - (send dc set-brush (make-object color% 0 0 0) 'solid) - (send dc draw-polygon (list (pt 2 0) (pt 2 4) - (pt 4 4) (pt 4 0))) - (send dc set-bitmap #f) - (send bm get-argb-pixels 0 0 5 5 bs) - (send dc set-bitmap bm2) - (send dc set-argb-pixels 0 0 5 5 bs) - (send dc get-argb-pixels 0 0 5 5 bs2) - (send dc set-bitmap #f) - (test #t 'mono-bits - (equal? - bs - (bytes-append - #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0\377\377\377\377\377" - #"\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0\377\377\377\377\377\377\377\377\377\0\0\0" - #"\377\0\0\0\377\0\0\0\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0" - #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0"))) - (test #t 'same-bits (equal? bs bs2))) - -;; ---------------------------------------- -;; Test draw-bitmap-section-smooth - -(let* ([bm (make-bitmap 100 100)] - [dc (make-object bitmap-dc% bm)] - [bm2 (make-bitmap 70 70)] - [dc2 (make-object bitmap-dc% bm2)] - [bm3 (make-bitmap 70 70)] - [dc3 (make-object bitmap-dc% bm3)]) - (send dc draw-ellipse 0 0 100 100) - (send dc2 draw-bitmap-section-smooth bm - 10 10 50 50 - 0 0 100 100) - (send dc3 scale 0.5 0.5) - (send dc3 set-smoothing 'aligned) - (send dc3 draw-bitmap bm 20 20) - (let ([s2 (make-bytes (* 4 70 70))] - [s3 (make-bytes (* 4 70 70))]) - (send bm2 get-argb-pixels 0 0 70 70 s2) - (send bm3 get-argb-pixels 0 0 70 70 s3) - (test #t 'same-scaled (equal? s2 s3)))) - -;; ---------------------------------------- -;; Test some masking combinations - -(let () - (define u (make-object bitmap% 2 2)) - (define mu (make-object bitmap% 2 2)) - (send u set-argb-pixels 0 0 2 2 - (bytes 255 100 0 0 - 255 0 0 0 - 255 100 0 0 - 255 255 255 255)) - (send mu set-argb-pixels 0 0 2 2 - (bytes 255 0 0 0 - 255 255 255 255 - 255 0 0 0 - 255 255 255 255)) - (send u set-loaded-mask mu) - (define (try-draw nonce-color mode expect - #:bottom? [bottom? #f]) - (let* ((b&w? (not (eq? mode 'color))) - (bm (make-object bitmap% 2 2 b&w?)) - (dc (make-object bitmap-dc% bm))) - (send dc clear) - (when (eq? mode 'black) - (send dc set-brush "black" 'solid) - (send dc draw-rectangle 0 0 2 2)) - ;; Check that draw-bitmap-section really uses the - ;; section, even in combination with a mask. - (send dc draw-bitmap-section u - 0 (if bottom? 1 0) - 0 (if bottom? 1 0) 2 1 - 'solid nonce-color (send u get-loaded-mask)) - (send dc set-bitmap #f) - (let ([s (make-bytes (* 2 2 4))]) - (send bm get-argb-pixels 0 0 2 2 s) - (when b&w? (send bm get-argb-pixels 0 0 2 2 s #t)) - (test expect 'masked-draw s)))) - (define usual-expect (bytes 255 100 0 0 - 255 255 255 255 - 255 255 255 255 - 255 255 255 255)) - (try-draw (make-object color% "green") 'color usual-expect) - (try-draw (make-object color%) 'color usual-expect) - (try-draw (make-object color%) 'white - ;; For b&w destination, check that the - ;; alpha is consistent with the drawn pixels - (bytes 255 0 0 0 - 0 255 255 255 - 0 255 255 255 - 0 255 255 255)) - (send mu set-argb-pixels 0 0 2 2 - (bytes 255 255 255 255 - 255 255 255 255 - 255 0 0 0 - 255 0 0 0)) - (try-draw (make-object color%) 'black - #:bottom? #t - ;; Another b&w destination test, this time - ;; with a mask that forces black pixels to - ;; white: - (bytes 255 0 0 0 - 255 0 0 0 - 255 0 0 0 - 0 255 255 255)) - (send mu set-argb-pixels 0 0 2 2 - (bytes 255 255 255 255 - 255 0 0 0 - 255 255 255 255 - 255 0 0 0)) - (try-draw (make-object color%) 'color - (bytes 255 255 255 255 - 255 0 0 0 - 255 255 255 255 - 255 255 255 255)) - (let ([dc (make-object bitmap-dc% mu)]) - (send dc erase) - (send dc set-pen "white" 1 'transparent) - (send dc set-brush "black" 'solid) - (send dc draw-rectangle 0 0 1 1) - (send dc set-bitmap #f)) - (try-draw (make-object color%) 'color usual-expect)) - -;; ---------------------------------------- -;; 0 alpha should make the RGB components irrelevant - -(let () - (define bm1 (make-bitmap 1 2)) - (define bm2 (make-bitmap 1 2)) - - (send bm1 set-argb-pixels 0 0 1 2 (bytes 0 0 0 0 - 255 0 0 255)) - (send bm2 set-argb-pixels 0 0 1 2 (bytes 255 255 0 0 - 0 0 0 0)) - - (define the-bytes (make-bytes 8 0)) - - (define bm3 (make-bitmap 1 2)) - (define bdc (make-object bitmap-dc% bm3)) - (void (send bdc draw-bitmap bm1 0 0)) - (void (send bdc draw-bitmap bm2 0 0)) - - (send bdc get-argb-pixels 0 0 1 2 the-bytes) - (test (bytes 255 255 0 0 - 255 0 0 255) - values - the-bytes)) - -;; ---------------------------------------- - -;; Check B&W drawing to B&W, 'solid vs. 'opaque -(let ([mk - (lambda (expect style bg-col col mask?) - (let* ((bm1 (make-object bitmap% 2 2 #t)) - (bm2 (make-object bitmap% 2 2 #t)) - (bm3 (make-object bitmap% 2 2 #t)) - (dc1 (new bitmap-dc% (bitmap bm1))) - (dc2 (new bitmap-dc% (bitmap bm2))) - (dc3 (new bitmap-dc% (bitmap bm3))) - (s (make-bytes 16))) - (send dc1 clear) - (send dc1 set-argb-pixels 0 0 2 1 #"\xFF\0\0\0\xFF\0\0\0") - (send dc2 clear) - (send dc2 set-argb-pixels 0 1 2 1 #"\xFF\0\0\0\xFF\0\0\0") - (send dc3 set-argb-pixels 0 0 2 2 (bytes-append #"\xFF\0\0\0\xFF\xFF\xFF\xFF" - #"\xFF\0\0\0\xFF\xFF\xFF\xFF")) - (send dc2 set-background bg-col) - (send dc2 draw-bitmap bm1 0 0 style col (and mask? bm3)) - (send dc2 set-bitmap #f) - (send bm2 get-argb-pixels 0 0 2 2 s) - (let ([col->str (lambda (c) - (if (zero? (send c red)) "black" "white"))]) - (test expect `(mk ,style ,(col->str bg-col) ,(col->str col), mask?) s))))] - [black (make-object color%)] - [white (make-object color% 255 255 255)]) - (mk #"\377\0\0\0\377\0\0\0\377\0\0\0\377\0\0\0" 'solid white black #f) - (mk #"\377\0\0\0\377\0\0\0\377\0\0\0\377\0\0\0" 'solid black black #f) - (mk #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0" 'solid black white #f) - (mk #"\377\0\0\0\377\377\377\377\377\0\0\0\377\0\0\0" 'solid white black #t) - (mk #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0" 'solid white white #t) - (mk #"\377\0\0\0\377\0\0\0\377\377\377\377\377\377\377\377" 'opaque white black #f) - (mk #"\377\0\0\0\377\0\0\0\377\0\0\0\377\0\0\0" 'opaque black black #f) - (mk #"\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377" 'opaque white white #f) - (mk #"\377\0\0\0\377\377\377\377\377\377\377\377\377\0\0\0" 'opaque white black #t) - (mk #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0" 'opaque black white #t)) - -;; ---------------------------------------- -;; check get-alpha mode of `get-argb-pixels' - -(let () - (define (get-column-alpha bm x y) - (define bs (make-bytes 4)) - (send bm get-argb-pixels x y 1 1 bs #t) - bs) - (define abm (make-object bitmap% 2 2 #f #t)) - (define nbm (make-object bitmap% 2 2 #f #f)) - (define (avg bstr) (- 255 - (quotient (+ (bytes-ref bstr 0) - (bytes-ref bstr 1) - (bytes-ref bstr 2)) - 3))) - (send abm set-argb-pixels 0 0 2 2 #"0123456789abcdef") - (send nbm set-argb-pixels 0 0 2 2 #"0123456789abcdef") ; alphas ignored - - (test (bytes (char->integer #\0) 0 0 0) 'a0+0 (get-column-alpha abm 0 0)) - (test (bytes (char->integer #\4) 0 0 0) 'a1+0 (get-column-alpha abm 1 0)) - (test (bytes (char->integer #\8) 0 0 0) 'a0+1 (get-column-alpha abm 0 1)) - (test (bytes (char->integer #\c) 0 0 0) 'a1+1 (get-column-alpha abm 1 1)) - - (test (bytes (avg #"123") 0 0 0) 'n0+0 (get-column-alpha nbm 0 0)) - (test (bytes (avg #"567") 0 0 0) 'n1+0 (get-column-alpha nbm 1 0)) - (test (bytes (avg #"9ab") 0 0 0) 'n0+1 (get-column-alpha nbm 0 1)) - (test (bytes (avg #"def") 0 0 0) 'n1+1 (get-column-alpha nbm 1 1))) - -;; ---------------------------------------- -;; check pre-mult mode of `{get,set}-argb-pixels' - -(let () - (define abm (make-object bitmap% 2 2 #f #t)) - (define nbm (make-object bitmap% 2 2 #f #f)) - (send abm set-argb-pixels 0 0 2 2 #"30127456b89afcde" #f #t) - (send nbm set-argb-pixels 0 0 2 2 #"0123456789abcdef" #f #t) ; alphas ignored - - (define (get-pixels bm pre-mult?) - (define bs (make-bytes 16)) - (send bm get-argb-pixels 0 0 2 2 bs #f pre-mult?) - bs) - - (define (unmul b) - (define (um v) (inexact->exact (round (/ (* v 255.) (bytes-ref b 0))))) - (bytes (bytes-ref b 0) - (um (bytes-ref b 1)) - (um (bytes-ref b 2)) - (um (bytes-ref b 3)))) - - (test #"\xFF123\xFF567\xFF9ab\xFFdef" 'no-alpha (get-pixels nbm #f)) - (test #"\xFF123\xFF567\xFF9ab\xFFdef" 'no-alpha (get-pixels nbm #t)) - - (test (apply bytes-append (map unmul '(#"3012" #"7456" #"b89a" #"fcde"))) - 'alpha-normal (get-pixels abm #f)) - (test #"30127456b89afcde" 'alpha-premult (get-pixels abm #t))) - -;; ---------------------------------------- -;; check consistency of pre-multiplication, drawing, etc. - -(let () - (define gray-cols (make-bitmap 256 256 #f)) ; no alpha channel - (let ([s (make-bytes (* 256 256 4))]) - (for* ([i 256] [j 256]) - (bytes-set! s (+ (* 4 i) (* j 256 4)) 255) - (bytes-set! s (+ (* 4 i) 1 (* j 256 4)) (- 255 i)) - (bytes-set! s (+ (* 4 i) 2 (* j 256 4)) (- 255 i)) - (bytes-set! s (+ (* 4 i) 3 (* j 256 4)) (- 255 i))) - (send gray-cols set-argb-pixels 0 0 256 256 s)) - - (define rainbow-rows (make-bitmap 256 256)) - (let ([s (make-bytes (* 256 256 4))]) - (for* ([i 256] [j 256]) - (bytes-set! s (+ (* 4 i) (* j 256 4)) 255) - (bytes-set! s (+ (* 4 i) 1 (* j 256 4)) j) - (bytes-set! s (+ (* 4 i) 2 (* j 256 4)) (modulo (+ j 10) 256)) - (bytes-set! s (+ (* 4 i) 3 (* j 256 4)) (modulo (+ j 20) 256))) - (send rainbow-rows set-argb-pixels 0 0 256 256 s)) - - (define rainbow-rows-alpha-cols (make-bitmap 256 256)) - (let ([s (make-bytes (* 256 256 4))]) - (for* ([i 256] [j 256]) - (bytes-set! s (+ (* 4 i) (* j 256 4)) i) - (bytes-set! s (+ (* 4 i) 1 (* j 256 4)) j) - (bytes-set! s (+ (* 4 i) 2 (* j 256 4)) (modulo (+ j 10) 256)) - (bytes-set! s (+ (* 4 i) 3 (* j 256 4)) (modulo (+ j 20) 256))) - (send rainbow-rows-alpha-cols set-argb-pixels 0 0 256 256 s)) - - (define rainbow-rows-alpha-cols-premult (make-bitmap 256 256)) - (let ([s (make-bytes (* 256 256 4))]) - (for* ([i 256] [j 256]) - (bytes-set! s (+ (* 4 i) (* j 256 4)) i) - (bytes-set! s (+ (* 4 i) 1 (* j 256 4)) (min i j)) - (bytes-set! s (+ (* 4 i) 2 (* j 256 4)) (min i (modulo (+ j 10) 256))) - (bytes-set! s (+ (* 4 i) 3 (* j 256 4)) (min i (modulo (+ j 20) 256)))) - (send rainbow-rows-alpha-cols-premult set-argb-pixels 0 0 256 256 s #f #t)) - - ;; Check that drawing with a mask is consistent with `set-argb-pixels' - ;; in non-premultiplied mode: - (let ([target (make-bitmap 256 256)]) - (define dc (make-object bitmap-dc% target)) - (send dc draw-bitmap rainbow-rows 0 0 - 'solid - (send the-color-database find-color "black") - gray-cols) - (let ([s1 (make-bytes (* 256 256 4))] - [s2 (make-bytes (* 256 256 4))]) - (send target get-argb-pixels 0 0 256 256 s1 #f #t) - (send rainbow-rows-alpha-cols get-argb-pixels 0 0 256 256 s2 #f #t) - (for ([i (in-range (* 256 256))]) - (unless (= (bytes-ref s1 i) (bytes-ref s2 i)) - (printf "~a ~a ~a\n" i (bytes-ref s1 i) (bytes-ref s2 i)))) - (test #t 'consistent-mult (equal? s1 s2)))) - - ;; Check that getting non-premult values out and putting them back in - ;; gives consistent premult results: - (let ([target (make-bitmap 256 256)]) - (let ([s1 (make-bytes (* 256 256 4))] - [s2 (make-bytes (* 256 256 4))]) - (send rainbow-rows-alpha-cols-premult get-argb-pixels 0 0 256 256 s1 #f #f) - (send target set-argb-pixels 0 0 256 256 s1 #f #f) - - (send target get-argb-pixels 0 0 256 256 s1 #f #t) - (send rainbow-rows-alpha-cols-premult get-argb-pixels 0 0 256 256 s2 #f #t) - (test #t 'consistent-premult (equal? s1 s2)))) - - (void)) - -;; ---------------------------------------- - -(let () - (define bm (make-screen-bitmap 100 100)) - (define dc (make-object bitmap-dc% bm)) - (define-values (aw ah aa ad) (send dc get-text-extent "x " #f #t)) - (define-values (bw bh ba bd) (send dc get-text-extent "x ⇒ y" #f #t)) - (test #t 'no-missing-glyph-truncation (bw . > . aw))) - -;; ---------------------------------------- - -(test #f 'no-commas (ormap (lambda (s) (regexp-match? #rx"," s)) (get-face-list))) -(test #t 'all-commas (andmap (lambda (s) (regexp-match? #rx"," s)) (get-face-list #:all-variants? #t))) - -;; ---------------------------------------- - -(define (check-immutable v) - (test 'immutable 'immutable - (with-handlers ([exn:fail? (lambda (x) - (if (regexp-match #rx"immutable" (exn-message x)) - 'immutable - x))]) - (send v set-color "red")))) - -(check-immutable (send the-brush-list find-or-create-brush "white" 'solid)) -(check-immutable (send the-pen-list find-or-create-pen "white" 1 'solid)) - -;; ---------------------------------------- - -(let ([color (new color%)]) - (test #f 'color (send color is-immutable?)) - (test 0 'color (send color red)) - (test 0 'color (send color green)) - (test 0 'color (send color blue)) - (test 1.0 'color (send color alpha))) - -(let ([color (make-color 101 102 103 0.9)]) - (test #t 'color (send color is-immutable?)) - (test 101 'color (send color red)) - (test 102 'color (send color green)) - (test 103 'color (send color blue)) - (test 0.9 'color (send color alpha))) - -(let ([color (make-color 0 0 0)]) - (test #t 'color (send color is-immutable?)) - (test 0 'color (send color red)) - (test 0 'color (send color green)) - (test 0 'color (send color blue)) - (test 1.0 'color (send color alpha))) - -;; ---------------------------------------- - -(let ([brush (new brush%)]) - (test #f 'brush (send brush is-immutable?))) - -(let ([brush (make-brush)]) - (test #t 'brush (send brush is-immutable?)) - (test #t 'brush (eq? brush (send the-brush-list find-or-create-brush "black" 'solid)))) - -(let ([brush (make-brush #:immutable? #f)]) - (test #f 'brush (send brush is-immutable?))) - -;; ---------------------------------------- - -(let ([pen (new pen%)]) - (test #f 'pen (send pen is-immutable?))) - -(let ([pen (make-pen)]) - (test #t 'pen (send pen is-immutable?)) - (test #t 'pen (eq? pen (send the-pen-list find-or-create-pen "black" 0 'solid)))) - -(let ([pen (make-pen #:immutable? #f)]) - (test #f 'pen (send pen is-immutable?))) - -;; ---------------------------------------- - -(let () - (define config (new gl-config%)) - (define bm1 (make-gl-bitmap 100 100 config)) - (define bm2 (make-gl-bitmap 100 100 config)) - (define dc1 (make-object bitmap-dc% bm1)) - (define dc2 (make-object bitmap-dc% bm2)) - (define gl1 (send dc1 get-gl-context)) - (define gl2 (send dc2 get-gl-context)) - (when (and gl1 gl2) - (send gl1 call-as-current - (lambda () - (test 5 'alt (send gl2 call-as-current - (lambda () (error "not in this context!")) - (wrap-evt always-evt (lambda (v) 5)))) - (sync - (thread - (lambda () - (test 8 'thread/alts - (send gl1 call-as-current - (lambda () (error "not in this thread!")) - (wrap-evt always-evt (lambda (v) 8))))))) - (test 8 'reenter (send gl1 call-as-current - (lambda () 8))))) - (with-handlers ([exn? void]) - (send gl1 call-as-current (lambda () (error "fail")))) - (test 12 'post-exn (send gl1 call-as-current (lambda () 12))))) - - -;; ---------------------------------------- -;; check clipping - -(let () - (define rdc (new record-dc%)) - (send rdc set-brush "green" 'solid) - (send rdc set-clipping-rect 2 2 5 5) - (send rdc draw-rectangle 0 0 9 9) - - (define bm (make-bitmap 25 25)) - (define bm-dc (make-object bitmap-dc% bm)) - - (send bm-dc set-clipping-rect 10 10 5 5) - - ((send rdc get-recorded-procedure) bm-dc) - - (define s (make-bytes (* 20 20 4))) - (send bm get-argb-pixels 0 0 20 20 s) - (for ([i (in-range 0 (* 20 20 4) 4)]) - (test 0 'record-dc-clipping-byte (bytes-ref s i)))) - -;; ---------------------------------------- - -(let ([bm (make-object bitmap% 1 1)]) - (test #t 'load-file (send bm load-file (collection-file-path "sk.jpg" "icons")))) - -;; ---------------------------------------- -;; Check save & load of monochrome PNG: - -(let () - (define N 5) - - (define bm (make-object bitmap% N N #t #f)) - (define dc (make-object bitmap-dc% bm)) - - (send dc draw-rectangle 2 2 (- N 2) (- N 2)) - - (define-values (i o) (make-pipe)) - (send bm save-file o 'png) - (close-output-port o) - - (define bm2 (make-object bitmap% 10 10)) - (send bm2 load-file i 'png) - - (define-values (i2 o2) (make-pipe)) - (send bm save-file o2 'png) - (close-output-port o2) - - (define bm3 (read-bitmap i2)) - - (define s1 (make-bytes (* N N 4))) - (define s2 (make-bytes (* N N 4))) - (define s3 (make-bytes (* N N 4))) - - (send bm get-argb-pixels 0 0 N N s1) - (send bm2 get-argb-pixels 0 0 N N s2) - (send bm3 get-argb-pixels 0 0 N N s3) - - (test #t 'same (equal? s1 s2)) - (test #t 'same (equal? s1 s3)) - (test 1 'mono (send bm2 get-depth)) - (test 1 'mono (send bm3 get-depth)) - (test #f 'b&w (send bm2 is-color?)) - (test #f 'b&w (send bm3 is-color?)) - (test #f 'no-alpha (send bm2 has-alpha-channel?)) - (test #f 'no-alpha (send bm3 has-alpha-channel?))) - -;; ---------------------------------------- -;; Check `in-region?' - -(let () - (define r (new region%)) - (send r set-rectangle 0 0 100 100) - (test #t 'yes/r (send r in-region? 10 10)) - (test #f 'no/r (send r in-region? 110 110)) - (test #f 'no/r (send r in-region? 10 110)) - - (define r2 (new region%)) - (send r2 set-rectangle 120 120 10 10) - (send r2 union r) - - (test #t 'yes/r (send r in-region? 10 10)) - (test #t 'yes/r2 (send r2 in-region? 10 10)) - (test #f 'no/r (send r in-region? 125 125)) - (test #t 'yes/r2 (send r2 in-region? 125 125)) - (test #f 'no/r2 (send r2 in-region? 110 110))) - -(let () - (define bm (make-bitmap 50 50)) - (define dc (send bm make-dc)) - (send dc translate 10 10) - (define r (make-object region% dc)) - (send r set-rectangle 0 0 100 100) - (test #t 'yes (send r in-region? 5 5)) - (test #f 'no (send r in-region? 110 110))) - -(let () - (define bm (make-bitmap 50 50)) - (define dc (send bm make-dc)) - (send dc translate 10 10) - ;; dc's translation at creation of region sticks: - (define r (make-object region% dc)) - (send r set-rectangle 0 0 100 100) - (send dc translate -10 -10) - (test #f 'no (send r in-region? 5 5)) - (test #t 'yes (send r in-region? 105 105))) - -;; ---------------------------------------- -;; Test get-path-bounding-box - -(define (test-square-bounding-boxes) - (define-syntax (box stx) - (syntax-case stx () - [(_ expr ...) - #'(let-values ([(left top width height) expr ...]) - (list left top width height))])) - (define dp ; a-square-path - (let ([dp (new dc-path%)]) - (send dp move-to 10 20) - (send dp line-to 30 20) - (send dp line-to 30 50) - (send dp line-to 10 50) - (send dp line-to 10 20) - (send dp close) - dp)) - - (define bm (make-object bitmap% 100 100)) - (define dc (new bitmap-dc% [bitmap bm])) - (send dc set-brush (send the-brush-list find-or-create-brush "red" 'solid)) - (send dc set-smoothing 'smoothed) - - (define (bbs pen-width) - (send dc set-pen (send the-pen-list find-or-create-pen "black" pen-width 'solid - 'projecting 'round)) - (define bb (box (send dp get-bounding-box))) - (define bb-path (box (send dc get-path-bounding-box dp 'path))) - (define bb-stroke (box (send dc get-path-bounding-box dp 'stroke))) - (define bb-fill (box (send dc get-path-bounding-box dp 'fill))) - (values bb bb-path bb-stroke bb-fill)) - (define (inside? b1 b2) ; is b2 inside b1? - (match-define (list x y w h) b1) - (match-define (list s t a b) b2) - (and (< x s) (< y t) (> w a) (> h a))) - (define (test w) - (define-values (n p s f) (bbs w)) - (when (= w 0) (set! w 1)) ; 1 is the hair line width - (and (inside? s p) ; p ignores pen width, s does not - (equal? n (list 10. 20. 20. 30.)) - (equal? p n); no control points outside the convex hull - (equal? s (list (- 10. (/ w 2)) (- 20. (/ w 2)) (+ 20. w) (+ 30. w))) - (equal? p f))) - (and (test 10) (test 1) (test 0))) - -(test #t 'get-path-bounding-box (test-square-bounding-boxes)) - -;; ----------------------------------------------------------- -;; Check pixel operations on a bitmap with a x2 backing scale - -(define (scaled-bm-test alpha?) - (let ([bm (make-bitmap 10 11 alpha? #:backing-scale 2)]) - (test 2.0 'scale (send bm get-backing-scale)) - (test 10 'width (send bm get-width)) - (test 11 'height (send bm get-height)) - - (define dc (send bm make-dc)) - (send dc set-pen "black" 0 'transparent) - (send dc set-brush (make-color 100 100 200) 'solid) - (send dc draw-rectangle 0 0 3 3) - (send dc draw-rectangle 9 9 1 1) - - (let ([s (make-bytes 4)]) - (send bm get-argb-pixels 2 2 1 1 s) - (test (list 255 100 100 200) 'scaled (bytes->list s)) - (send bm get-argb-pixels 4 4 1 1 s) - (test (if alpha? 0 255) 'scaled (bytes-ref s 0)) - (send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t) - (test (list 255 100 100 200) 'unscaled (bytes->list s)) - - (bytes-copy! s 0 (bytes 0 1 2 3)) - (send bm get-argb-pixels 2 2 1 1 s #:unscaled? #t 'just-alpha) - ;; for (not alpha?), 122 is the mask equivalent of the brush color - (test (list (if alpha? 255 122) 1 2 3) 'unscaled-alpha (bytes->list s)) - - (bytes-copy! s 0 (bytes 0 1 2 3)) - (send bm get-argb-pixels 9 9 1 1 s #:unscaled? #t 'just-alpha) - (test (list 0 1 2 3) 'unscaled-alpha-miss (bytes->list s)) - (send bm get-argb-pixels 18 18 1 1 s #:unscaled? #t 'just-alpha) - (test (list (if alpha? 255 122) 1 2 3) 'unscaled-alpha-hit (bytes->list s)) - - (send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0" - #:unscaled? #t) - (send bm get-argb-pixels 0 0 1 1 s #:unscaled? #t) - (test (list 255 0 0 0) 'unscaled (bytes->list s)) - ;; scaled is average of black and blue: - (send bm get-argb-pixels 0 0 1 1 s) - (test (list 255 50 50 100) 'scaled (bytes->list s)) - - (send bm set-argb-pixels 0 0 2 1 #"\xff\x0\x0\x0\xff\x0\x0\x0") - (send bm get-argb-pixels 0 0 1 1 s) - (test (list 255 0 0 0) 'scaled (bytes->list s)) - - (when (not alpha?) - (bytes-copy! s 0 (bytes 100 1 2 3)) - (send bm set-argb-pixels 9 9 1 1 s #:unscaled? #t 'just-alpha) - (send bm get-argb-pixels 9 9 1 1 s #:unscaled? #t) - (test (list 255 155 155 155) 'unscaled-alpha-set (bytes->list s)) - (bytes-copy! s 0 (bytes 100 1 2 3)) - (send bm set-argb-pixels 18 18 1 1 s #:unscaled? #t 'just-alpha) - (send bm get-argb-pixels 18 18 1 1 s #:unscaled? #t) - (test (list 255 155 155 155) 'unscaled-alpha-set-far (bytes->list s)))))) - - -(scaled-bm-test #t) -(scaled-bm-test #f) - -(let ([p (collection-file-path "sk.jpg" "icons")]) - (let ([bm1 (read-bitmap p)] - [bm2 (read-bitmap p #:backing-scale 2)]) - (test 2.0 'scale (send bm2 get-backing-scale)) - (test (ceiling (* 1/2 (send bm1 get-width))) 'read-width (send bm2 get-width)) - (test (ceiling (* 1/2 (send bm1 get-height))) 'read-height (send bm2 get-height)))) - -(let ([p (collection-file-path "very-small-planet.png" "icons")]) - (define-syntax-rule (test-fail rx body) - (test #t - 'error - (with-handlers ([exn? (lambda (e) - (regexp-match? rx (exn-message e)))]) - body - #f))) - (test-fail "mask.*backing scale" (read-bitmap p - 'png/mask - #:backing-scale 2)) - (test-fail "can only install a mask.*backing scale" - (send (read-bitmap p #:backing-scale 2) - set-loaded-mask - (read-bitmap p))) - (test-fail "can only load a file.*backing scale" - (send (read-bitmap p #:backing-scale 2) - load-file - p))) - -;; ---------------------------------------- -;; Check `get-char-width` and backing scales: - -(let ([dc1 (send (make-bitmap 10 10) make-dc)] - [dc2 (send (make-bitmap 10 10 #:backing-scale 2) make-dc)]) - ;; Sizes don't have to be the same, since they can depend on resolution, - ;; but they should be close: - (test (round (send dc1 get-char-width)) - 'scale-2-width - (round (send dc2 get-char-width))) - (test (round (send dc1 get-char-height)) - 'scale-2-height - (round (send dc2 get-char-height)))) - -;; ---------------------------------------- -;; No error on too-large bitmap: - -(st #f (make-bitmap 1000000 1000000) ok?) - -;; ---------------------------------------- -;; No # checks on certain class instances - -(test #f 'undef-pen (impersonator? (new pen%))) -(test #f 'undef-brush (impersonator? (new brush%))) -(test #f 'undef-color (impersonator? (new color%))) - -;; ---------------------------------------- - -(report-errs) diff --git a/gui-test/tests/gracket/draw.rkt b/gui-test/tests/gracket/draw.rkt deleted file mode 100644 index 9228d01e..00000000 --- a/gui-test/tests/gracket/draw.rkt +++ /dev/null @@ -1,1501 +0,0 @@ -#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) - (collection-file-path f "icons"))) - -(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)] - [hp2.75 (new horizontal-panel% [parent vp] - [stretchable-height #f])] - [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] - [screen-bitmap? #f] - [compat-bitmap? #f] - [scaled-bitmap? #f] - [use-record? #f] - [serialize-record? #f] - [use-bad? #f] - [depth-one? #f] - [cyan? #f] - [multi-page? #f] - [smoothing 'unsmoothed] - [align-scale 1.0] - [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 (collection-file-path "draw-info.txt" "tests/gracket")))) - (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) - (define c-rotate 0) - (define c-gray? #f) - (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 (mode) (set! c-clip mode) (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))] - [set-canvas-rotation (lambda (r) (set! c-rotate r) (refresh))] - [set-canvas-gray (lambda (g?) (set! c-gray? g?) (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))]) - (cond - [platform-bitmap? - (make-platform-bitmap w h)] - [screen-bitmap? - (make-screen-bitmap w h)] - [compat-bitmap? - (send this make-bitmap w h)] - [scaled-bitmap? - (make-bitmap w h #:backing-scale 3.0)] - [else - (make-object bitmap% w h depth-one? c-gray?)]))) - #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))) - ;; Rotated Chinese character: - (send dc draw-text s (+ x h (- d)) (+ y h 2) kern? 0 (* pi -1/2)) - ;; 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?)) - (when c-gray? - (let ([b (send can-dc get-brush)] - [p (send can-dc get-pen)]) - (send can-dc set-brush "gray" 'solid) - (send can-dc set-pen "black" 1 'transparent) - (send can-dc draw-rectangle 0 0 1024 1024) - (send can-dc set-brush b) - (send can-dc set-pen p))) - (send can-dc set-origin c-offset c-offset) - (send can-dc set-rotation c-rotate) - (send can-dc set-scale c-xscale c-yscale) - (send can-dc set-alpha current-c-alpha) - (when c-clip - (define r (new region%)) - (case c-clip - [(square) (send r set-rectangle 0 0 200 200)] - [(squares) - (define r2 (new region%)) - (send r set-rectangle 0 0 200 200) - (send r2 set-rectangle 210 210 40 40) - (send r union r2)] - [(octagon) (send r set-polygon octagon)]) - (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 erase) - - (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-alignment-scale align-scale) - - (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 erase) - - (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" "Screen" "Compatible" "Backing x3" "Record" "Serialize" "Bad") hp0 - (lambda (self event) - (set! use-bitmap? (< 0 (send self get-selection))) - (set! depth-one? (= 2 (send self get-selection))) - (set! platform-bitmap? (= 3 (send self get-selection))) - (set! screen-bitmap? (= 4 (send self get-selection))) - (set! compat-bitmap? (= 5 (send self get-selection))) - (set! scaled-bitmap? (= 6 (send self get-selection))) - (set! use-record? (<= 7 (send self get-selection) 8)) - (set! serialize-record? (= 8 (send self get-selection))) - (set! use-bad? (< 9 (send self get-selection))) - (send canvas refresh))) - (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") - hp - (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" hp - (lambda (self event) - (send canvas set-kern (send self get-value)))) - (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 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 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 choice% #f '("Align 1.0" "Align 2.0" "Align 3.0" "Align 0.5") hp2.5 - (lambda (self event) - (set! align-scale (list-ref '(1.0 2.0 3.0 0.5) - (send self get-selection))) - (send canvas refresh))) - (make-object button% "Clock" hp2.5 (lambda (b e) (do-clock #f))) - (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") - hp2.75 - (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" hp2.75 - (lambda (self event) - (send canvas set-clip-pre-scale (send self get-value)))) - (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp2.75 - (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" hp2.75 - (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 check-box% "Cvs rot" hp3 - (lambda (self event) - (send canvas set-canvas-rotation (if (send self get-value) (* pi -1/5) 0)))) - (make-object choice% "Cvs Clip" '("None" "Empty" "Square" "Squares" "Octagon") hp3 - (lambda (self event) - (send canvas set-canvas-clip (case (send self get-selection) - [(0) #f] - [(1) 'empty] - [(2) 'square] - [(3) 'squares] - [(4) 'octagon])))) - (make-object check-box% "Cvs Gray" hp3 - (lambda (self event) - (send canvas set-canvas-gray (send self get-value)))) - (make-object button% "PS" hp3 - (lambda (self event) - (send canvas on-paint 'ps))) - (make-object button% "PDF" hp3 - (lambda (self event) - (send canvas on-paint 'pdf))) - (make-object button% "SVG" hp3 - (lambda (self event) - (send canvas on-paint 'svg))) - (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" hp2.75 (lambda (b e) (clock #t))) - (make-object check-box% "Multiple Pages" hp2.75 - (lambda (self event) - (set! multi-page? (send self get-value)))) - (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)) - -;; For test mode, check that we can at least start, -;; but exit right away: -(module+ test - (queue-callback (lambda () (exit)) #f)) diff --git a/gui-test/tests/gracket/font-maps.rkt b/gui-test/tests/gracket/font-maps.rkt deleted file mode 100644 index fc9a789b..00000000 --- a/gui-test/tests/gracket/font-maps.rkt +++ /dev/null @@ -1,37 +0,0 @@ -#lang racket -(require racket/draw) - -;; Check for pollution of font metrics from differently -;; scaled contexts. - -(define font (make-font #:face "Times")) - -;; Running `go` might affect the result of `go2` -(define (go) - (define bm (make-bitmap 1 1)) - (send (send bm make-dc) get-text-extent - "Extra regexp" - font - #t)) - -;; `go2` is like `go`, but for a different scale -(define (go2) - (define bm2 (make-platform-bitmap 1 1)) - (define dc (send bm2 make-dc)) - (send dc scale 1.25 1.25) - (send dc get-text-extent - "Extra regexp" - font - #t)) - -;; Running `go2` again in a separate place might produce -;; results unaffected by `go`: -(define (go2/p) - (place pch (place-channel-put pch (call-with-values go2 list)))) - -(module+ test - (call-with-values go void) - (define l1 (call-with-values go2 list)) - (define l2 (sync (go2/p))) - (unless (equal? l1 l2) - (error 'different "~s ~s" l1 l2))) diff --git a/gui-test/tests/gracket/gif.rkt b/gui-test/tests/gracket/gif.rkt deleted file mode 100644 index 466a97f3..00000000 --- a/gui-test/tests/gracket/gif.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang racket/base -(require file/gif - rackunit) - -(define g (gif-start (open-output-bytes) 10 10 0 #f)) -(check-equal? #t (gif-stream? g)) -(check-equal? #t (image-ready-gif-stream? g)) -(check-equal? #t (image-or-control-ready-gif-stream? g)) -(check-equal? #t (empty-gif-stream? g)) - diff --git a/gui-test/tests/gracket/png.rkt b/gui-test/tests/gracket/png.rkt deleted file mode 100644 index 47fae4b1..00000000 --- a/gui-test/tests/gracket/png.rkt +++ /dev/null @@ -1,178 +0,0 @@ -#lang racket/gui -(require racket/list) - -(module test racket/base) ; no test - -(define png-suite (build-path (or (current-load-relative-directory) - (current-directory)) - "png-suite")) - -(unless (directory-exists? png-suite) - (error 'png-test - (string-append - "The png-suite subdirectory appears to be missing. " - "It should contain the PNG test files (including GIFs for comparisons)."))) - -(define l (map (lambda (f) (path->string (build-path png-suite f))) - (sort (filter (lambda (x) (regexp-match #rx"^[^x].*[.]png$" x)) - (directory-list png-suite)) - pathgif f) - (regexp-replace #rx"[.]png$" f ".gif")) - -(define f (make-object frame% "Tester")) -(define name (new message% - [label (car l)] - [parent f] - [stretchable-width #t])) -(define no-mask-bm (let* ([bm (make-object bitmap% 32 32 1)] - [dc (make-object bitmap-dc% bm)]) - (send dc clear) - (send dc draw-line 0 0 32 32) - (send dc draw-line 0 32 32 0) - (send dc set-bitmap #f) - bm)) - -(define last-bm (make-object bitmap% (car l))) - -(define ppng (make-object horizontal-panel% f)) -(define png (new message% - [label last-bm] - [parent ppng] - [stretchable-width #t] - [stretchable-height #t])) -(define pngm (new message% - [label no-mask-bm] - [parent ppng] - [stretchable-width #t] - [stretchable-height #t])) -(define png-canvas (new canvas% - [parent ppng] - [stretchable-width #t] - [stretchable-height #t] - [paint-callback (lambda (c dc) - (send dc set-brush - (send the-brush-list find-or-create-brush "GREEN" 'solid)) - (send dc draw-rectangle -1 -1 500 500) - (send dc draw-bitmap - last-bm 0 0 - 'solid - (send the-color-database find-color "BLACK") - (send last-bm get-loaded-mask)))])) -(define ppng-mono (make-object vertical-panel% ppng)) -(define mono? (new message% - [label "mono"] - [parent ppng-mono])) -(define mono-mask? (new message% - [label "mono mask"] - [parent ppng-mono])) -(unless (= 1 (send last-bm get-depth)) - (send mono? show #f)) -(unless (and (send last-bm get-loaded-mask) - (= 1 (send (send last-bm get-loaded-mask) get-depth))) - (send mono-mask? show #f)) - -(define gif (new message% - [label (make-object bitmap% (png->gif (car l)))] - [parent f] - [stretchable-width #t] - [stretchable-height #t])) - -(define pld (make-object group-box-panel% "Save and Reload" f)) -(new button% - [label "Go"] - [parent pld] - [callback (lambda (b e) - (if (send last-bm save-file "tmp.png" 'png) - (let ([bm (make-object bitmap% "tmp.png" (get-mask-mode) (get-bg-color))]) - (send ld-png set-label (if (send bm ok?) - bm - no-mask-bm)) - (send ld-pngm set-label (or (send bm get-loaded-mask) - no-mask-bm)) - (send ld-mono? show (and (send bm ok?) - (= 1 (send bm get-depth)))) - (send ld-mono-mask? show (and (send bm get-loaded-mask) - (= 1 (send (send bm get-loaded-mask) get-depth))))) - (error "write failed!")))]) -(define ppld (make-object horizontal-panel% pld)) -(define ld-png (new message% - [label no-mask-bm] - [parent ppld] - [stretchable-width #t] - [stretchable-height #t])) -(define ld-pngm (new message% - [label no-mask-bm] - [parent ppld] - [stretchable-width #t] - [stretchable-height #t])) -(define ppld-mono (make-object vertical-panel% ppld)) -(define ld-mono? (new message% - [label "mono"] - [parent ppld-mono])) -(define ld-mono-mask? (new message% - [label "mono mask"] - [parent ppld-mono])) -(send ld-mono? show #f) -(send ld-mono-mask? show #f) - -(define mask (new choice% - [label "Alpha"] - [choices '("Auto" "Mask")] - [parent f] - [callback (lambda (c e) (refresh))])) -(define bg (new choice% - [label "Background"] - [choices '("Default" "White" "Black" "Red")] - [parent f] - [callback (lambda (c e) (refresh))])) - -(define slider - (new slider% - [label #f] - [parent f] - [min-value 1] - [max-value (length l)] - [init-value 1] - [callback (lambda (s e) (refresh))])) -(let ([p (make-object horizontal-panel% f)]) - (make-object button% "Prev" p (lambda (b e) - (send slider set-value (max 1 (sub1 (send slider get-value)))) - (refresh))) - (make-object vertical-pane% p) - (make-object button% "Next" p (lambda (b e) - (send slider set-value (min (length l) (add1 (send slider get-value)))) - (refresh)))) - -(define (refresh) - (let ([n (list-ref l (sub1 (send slider get-value)))]) - (send name set-label n) - (let ([bm (make-object bitmap% n (get-mask-mode) (get-bg-color))]) - (set! last-bm bm) - (send png set-label bm) - (send pngm set-label (or (send bm get-loaded-mask) - no-mask-bm))) - (send gif set-label (make-object bitmap% (png->gif n))) - (send mono? show (= 1 (send last-bm get-depth))) - (send mono-mask? show (and (send last-bm get-loaded-mask) - (= 1 (send (send last-bm get-loaded-mask) get-depth)))) - (send png-canvas refresh))) - -(define (get-mask-mode) - (case (send mask get-selection) - [(0) 'unknown] - [(1) 'unknown/mask])) - -(define get-bg-color - (let ([white (make-object color% 255 255 255)] - [black (make-object color% 0 0 0)] - [red (make-object color% 255 0 0)]) - (lambda () - (case (send bg get-selection) - [(0) #f] - [(1) white] - [(2) black] - [(3) red])))) - -(send f show #t) diff --git a/gui-test/tests/gracket/record-dc.rkt b/gui-test/tests/gracket/record-dc.rkt deleted file mode 100644 index 8c072aca..00000000 --- a/gui-test/tests/gracket/record-dc.rkt +++ /dev/null @@ -1,61 +0,0 @@ -#lang racket/base -(require racket/class - racket/draw - (only-in racket/draw/private/record-dc - record-dc-mixin - get-recorded-command)) - -(define bm1 (make-bitmap 100 100)) -(define bm2 (make-bitmap 100 100)) -(define bm3 (make-bitmap 100 100)) - -(define dc1 (make-object bitmap-dc% bm1)) -(define dc2 (make-object (record-dc-mixin bitmap-dc%) bm2)) -(define dc3 (make-object bitmap-dc% bm3)) - -(define (config dc) - (send dc set-origin 2 3) - (send dc set-scale 1.1 0.9) - (send dc set-rotation 0.1) - (send dc set-initial-matrix '#(1.0 -0.1 0.1 1.0 1.0 2.0)) - (send dc set-pen "red" 2 'solid) - (send dc set-brush "blue" 'solid) - (send dc set-font (make-font #:size 32)) - (send dc set-smoothing 'smoothed) - (send dc set-text-mode 'solid) - (send dc set-alpha 0.8) - (send dc set-clipping-rect 5 5 95 95)) - -(define (draw dc) - (send dc draw-ellipse 2 2 100 100) - (send dc draw-text "Hello" 10 10)) - -(define (get-bytes bm) - (define w (send bm get-width)) - (define h (send bm get-height)) - (define bstr (make-bytes (* 4 w h))) - (send bm get-argb-pixels 0 0 w h bstr) - bstr) - -(config dc1) -(draw dc1) - -(define pre-bytes (get-bytes bm1)) - -(config dc2) -(send dc2 erase) -(draw dc2) - -(define middle-bytes (get-bytes bm2)) - -(define cms (send dc2 get-recorded-command)) - -(void (cms dc3)) - -(define post-bytes (get-bytes bm3)) - -(unless (equal? pre-bytes middle-bytes) - (error "middle != pre")) - -(unless (equal? pre-bytes post-bytes) - (error "post != pre")) diff --git a/gui-test/tests/gracket/test.rkt b/gui-test/tests/gracket/test.rkt index b5e29b0b..861aa17d 100644 --- a/gui-test/tests/gracket/test.rkt +++ b/gui-test/tests/gracket/test.rkt @@ -4,6 +4,5 @@ (load-relative "editor.rktl") (load-relative "paramz.rktl") -(load-relative "dc.rktl") (load-relative "cache-image-snip-test.rktl") (load-relative "windowing.rktl") diff --git a/gui-test/tests/gracket/unsafe-draw.rkt b/gui-test/tests/gracket/unsafe-draw.rkt deleted file mode 100644 index ff5b82cd..00000000 --- a/gui-test/tests/gracket/unsafe-draw.rkt +++ /dev/null @@ -1,36 +0,0 @@ -#lang racket/base -(require ffi/unsafe - racket/draw/unsafe/cairo-lib - racket/draw/unsafe/brush) - -(provide surface-brush) - -(define cairo_image_surface_create - (get-ffi-obj 'cairo_image_surface_create cairo-lib (_fun _int _int _int -> _pointer))) -(define cairo_surface_destroy - (get-ffi-obj 'cairo_surface_destroy cairo-lib (_fun _pointer -> _void))) -(define cairo_create - (get-ffi-obj 'cairo_create cairo-lib (_fun _pointer -> _pointer))) -(define cairo_destroy - (get-ffi-obj 'cairo_destroy cairo-lib (_fun _pointer -> _void))) - -(define cairo_set_source_rgba - (get-ffi-obj 'cairo_set_source_rgba cairo-lib (_fun _pointer _double* _double* _double* _double* -> _void))) -(define cairo_rectangle - (get-ffi-obj 'cairo_rectangle cairo-lib (_fun _pointer _double* _double* _double* _double* -> _void))) -(define cairo_fill - (get-ffi-obj 'cairo_fill cairo-lib (_fun _pointer -> _void))) - -(define s (cairo_image_surface_create 0 20 30)) -(define cr (cairo_create s)) -(cairo_set_source_rgba cr 1.0 0.0 0.0 0.5) -(cairo_rectangle cr 2 2 16 26) -(cairo_fill cr) -(cairo_set_source_rgba cr 0.0 0.0 0.0 1.0) -(cairo_rectangle cr 9 9 2 2) -(cairo_fill cr) -(cairo_destroy cr) - -(define surface-brush (make-handle-brush s 20 30 '#(#(1 0 0 1 420 320) 0 0 1 1 0))) - -(cairo_surface_destroy s)