diff --git a/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt b/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt index eb8e101ef7..f3e96fc38c 100644 --- a/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt +++ b/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt @@ -958,6 +958,7 @@ has been moved out). (let ([color (get-color-arg (text-color np-atomic-shape))]) (send dc set-text-foreground (cond + [(equal? color "transparent") transparent-color] [(string? color) (or (send the-color-database find-color color) (send the-color-database find-color "black"))] @@ -1195,9 +1196,11 @@ the mask bitmap and the original bitmap are all together in a single bytes! (define (get-color-arg color [extra-alpha 255]) (cond + [(equal? color "transparent") transparent-color] [(string? color) - (define color-obj (or (send the-color-database find-color color) - (send the-color-database find-color "black"))) + (define color-obj + (or (send the-color-database find-color color) + (send the-color-database find-color "black"))) (make-object color% (send color-obj red) (send color-obj green) @@ -1211,6 +1214,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! (* (/ (color-alpha color) 255) (/ extra-alpha 255)))])) +(define transparent-color (make-object color% 255 255 255 0)) (define (pen->pen-obj/cache pen) (send the-pen-list find-or-create-pen @@ -1343,3 +1347,4 @@ the mask bitmap and the original bitmap are all together in a single bytes! (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) (provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?) + diff --git a/pkgs/htdp/2htdp/private/img-err.rkt b/pkgs/htdp/2htdp/private/img-err.rkt index c11c77af2e..f33e400610 100644 --- a/pkgs/htdp/2htdp/private/img-err.rkt +++ b/pkgs/htdp/2htdp/private/img-err.rkt @@ -203,13 +203,14 @@ [(color? arg) arg] [(pen? arg) arg] [else - (let* ([color-str - (if (symbol? arg) - (symbol->string arg) - arg)]) - (if (send the-color-database find-color color-str) - color-str - "black"))])] + (define color-str + (if (symbol? arg) + (symbol->string arg) + arg)) + (cond + [(equal? color-str "transparent") "transparent"] + [(send the-color-database find-color color-str) color-str] + [else "black"])])] [(color-list) (check-arg fn-name (and (list? arg) (andmap image-color? arg)) 'color-list i arg) arg] diff --git a/pkgs/htdp/2htdp/tests/test-image.rkt b/pkgs/htdp/2htdp/tests/test-image.rkt index 4d20962411..f774b35bce 100644 --- a/pkgs/htdp/2htdp/tests/test-image.rkt +++ b/pkgs/htdp/2htdp/tests/test-image.rkt @@ -115,7 +115,8 @@ (loop (image-bb x)) (loop (image-normalized? x)))] [(object? x) - ;; add a random number here to hack around the way Eli's tester treats two errors as a passing test + ;; add a random number here to hack around the way Eli's + ;; tester treats two errors as a passing test (error 'round-numbers/proc "cannot handle objects ~a" (random))] [(let-values ([(a b) (struct-info x)]) a) => @@ -317,6 +318,21 @@ => (rectangle 10 10 'solid 'black)) +(test (overlay (rectangle 10 10 'solid "blue") + (rectangle 10 10 'solid "transparent")) + => + (rectangle 10 10 'solid "blue")) + +(test (overlay (rectangle 10 10 'solid 'transparent) + (rectangle 10 10 'solid "blue")) + => + (rectangle 10 10 'solid "blue")) + +(test (overlay (rectangle 10 10 'solid "blue") + (rectangle 10 10 'solid "transparent")) + => + (rectangle 10 10 'solid "blue")) + ;; test zero sized image equalities (test (rectangle 0 100 'solid 'white) @@ -796,7 +812,8 @@ => (make-translate 125 150 (make-ellipse 50 100 0 255 "blue"))) -(test (normalize-shape (make-translate 10 20 (make-translate 100 100 (image-shape (ellipse 50 100 'solid 'blue))))) +(test (normalize-shape + (make-translate 10 20 (make-translate 100 100 (image-shape (ellipse 50 100 'solid 'blue))))) => (make-translate 135 170 (make-ellipse 50 100 0 255 "blue"))) @@ -2364,7 +2381,8 @@ (lambda (p) (display (convert i 'png-bytes) p)) #:exists 'truncate) - (define i2 (rotate 0 (read-bitmap tmpfile))) ;; add rotate to be sure we get an image so that equal? works properly + ;; add rotate to be sure we get an image so that equal? works properly + (define i2 (rotate 0 (read-bitmap tmpfile))) (delete-file tmpfile) (test (image-width i2) => 30) (test (image-height i2) => 30) @@ -2438,7 +2456,8 @@ (let loop ([obj obj]) (when (struct? obj) (let ([stuff (vector->list (struct->vector obj))]) - (unless (member (car stuff) '(struct:flip struct:translate struct:scale)) ;; skip these because normalization eliminates them + ;; skip these because normalization eliminates them + (unless (member (car stuff) '(struct:flip struct:translate struct:scale)) (hash-set! counts (car stuff) (+ 1 (hash-ref counts (car stuff) 0)))) (for-each loop (cdr stuff))))) (sort (hash-map counts list) string<=? #:key (λ (x) (symbol->string (car x)))))) @@ -2552,6 +2571,7 @@ This was found by the first redex check above: (max 0 (min (image-height i) (+ (* 10 2) 12))) (+ (* 10 1) 7) (+ (* 10 1) 2) i)) -raises an exception crop: expected as first argument, given: 0 +raises an exception crop: expected +as first argument, given: 0 |# diff --git a/pkgs/htdp/teachpack/2htdp/scribblings/image.scrbl b/pkgs/htdp/teachpack/2htdp/scribblings/image.scrbl index f31bb3c39e..4e5646dcd3 100644 --- a/pkgs/htdp/teachpack/2htdp/scribblings/image.scrbl +++ b/pkgs/htdp/teachpack/2htdp/scribblings/image.scrbl @@ -1435,8 +1435,9 @@ This section lists predicates for the basic structures provided by the image lib are also allowed, and are the same colors as in the previous sentence. If a string or symbol color name is not recognized, black is used in its place. - The complete list of colors is available in the documentation for - @racket[color-database<%>]. + The complete list of colors is the same as the colors allowed in + @racket[color-database<%>], plus the color @racket["transparent"], a transparent + color. }