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

2htdp/image: added support for alpha as a mode? argument

Browse Source 
original commit: 7716851cdea19f2bab410fc16938bf500066f7d0
This commit is contained in:
Robby Findler 2011-01-01 20:01:50 -06:00
parent c43e3e0fc7
commit e696606631
1 changed files with 28 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/mrlib/image-core.rkt
View File

@ -1042,31 +1042,44 @@ the mask bitmap and the original bitmap are all together in a single bytes!
[else 'smoothed])) [else 'smoothed]))
(define (mode-color->pen mode color) (define (mode-color->pen mode color)
(case mode (cond
[(outline) [(eq? mode 'outline)
(cond (cond
[(pen? color) [(pen? color)
(pen->pen-obj/cache color)] (pen->pen-obj/cache color)]
[else [else
(send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])] (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])]
[(solid) [else
(send the-pen-list find-or-create-pen "black" 1 'transparent)])) (send the-pen-list find-or-create-pen "black" 1 'transparent)]))
(define (mode-color->brush mode color) (define (mode-color->brush mode color)
(case mode (cond
[(outline) [(eq? mode 'outline)
(send the-brush-list find-or-create-brush "black" 'transparent)] (send the-brush-list find-or-create-brush "black" 'transparent)]
[(solid) [else
(send the-brush-list find-or-create-brush (get-color-arg color) 'solid)])) ;; this should only be 'solid if we have an old image from a save file somewhere
(define extra-alpha (if (eq? mode 'solid)
255
mode))
(send the-brush-list find-or-create-brush (get-color-arg color extra-alpha) 'solid)]))
(define (get-color-arg color) (define (get-color-arg color [extra-alpha 255])
(if (string? color) (cond
color [(string? color)
(make-object color% (define color-obj (or (send the-color-database find-color color)
(color-red color) (send the-color-database find-color "black")))
(color-green color) (make-object color%
(color-blue color) (send color-obj red)
(/ (color-alpha color) 255)))) (send color-obj green)
(send color-obj blue)
(/ extra-alpha 255))]
[else
(make-object color%
(color-red color)
(color-green color)
(color-blue color)
(* (/ (color-alpha color) 255)
(/ extra-alpha 255)))]))
(define (pen->pen-obj/cache pen) (define (pen->pen-obj/cache pen)