suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add transparent "color" to 2htdp/image.

Browse Source
This commit is contained in:
Robby Findler 2013-07-01 20:59:28 -05:00
parent dfafc9675e
commit 115722a261
4 changed files with 43 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt
View File

@ -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?)

15
pkgs/htdp/2htdp/private/img-err.rkt
View File

@ -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]

30
pkgs/htdp/2htdp/tests/test-image.rkt
View File

@ -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 <number that is between 0 than the width (-1)> as first argument, given: 0
raises an exception crop: expected <number that is between 0 than the width (-1)>
as first argument, given: 0
|#

5
pkgs/htdp/teachpack/2htdp/scribblings/image.scrbl
View File

@ -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.
}