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

fixes to bitmap%, especially mask vs. alpha mode

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-01 06:57:03 -06:00
parent 3d9c68105e
commit 439683af5e
8 changed files with 39 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/mred/private/wx/cocoa/image.rkt
View File

@ -57,8 +57,9 @@
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(when (send bm get-loaded-mask)
(send bm get-argb-pixels 0 0 w h str #t))
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])

2
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -95,7 +95,7 @@
(define-unimplemented draw-tab-base)
(define-unimplemented key-symbol-to-integer)
(define (get-control-font-size) 13)
(define-unimplemented cancel-quit)
(define (cancel-quit) (void))
(define-unimplemented fill-private-color)
(define (flush-display) (void))
(define-unimplemented write-resource)

4
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -33,9 +33,9 @@
(define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate)
[]
[-a _BOOL (applicationShouldTerminate: [_id app])
[-a _int (applicationShouldTerminate: [_id app])
(queue-quit-event)
#f]
0]
[-a _BOOL (openPreferences: [_id app])
(log-error "prefs")
#t])

6
collects/mred/private/wx/gtk/message.rkt
View File

@ -56,8 +56,10 @@
[(caution) (gtk_image_new_from_stock "gtk-dialog-warning" icon-size)]
[(stop) (gtk_image_new_from_stock "gtk-dialog-error" icon-size)]
[else (gtk_image_new_from_stock "gtk-dialog-question" icon-size)])
(gtk_image_new_from_pixbuf
(bitmap->pixbuf label))))]
(if (send label ok?)
(gtk_image_new_from_pixbuf
(bitmap->pixbuf label))
(gtk_label_new_with_mnemonic "<bad-image>"))))]
[no-show? (memq 'deleted style)])
(set-auto-size)

5
collects/mred/private/wx/gtk/pixbuf.rkt
View File

@ -36,8 +36,9 @@
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(when (send bm get-loaded-mask)
(send bm get-argb-pixels 0 0 w h str #t))
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])

35
collects/racket/draw/bitmap.rkt
View File

@ -251,6 +251,7 @@
;; Using libpng directly:
(let-values ([(r w h b&w? alpha?) (create-png-reader
in
(memq kind '(png/mask png/alpha))
(and bg
(list (send bg red)
(send bg green)
@ -258,7 +259,7 @@
(let ([rows (read-png r)])
(destroy-png-reader r)
(let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)]
[pre? (and alpha? (memq kind '(png/alpha png/mask)))])
[pre? (and alpha? (eq? kind 'png/alpha))])
(install-bytes-rows s w h rows b&w? alpha? pre? #f)
(values s b&w?))))]
[(jpeg jpeg/alpha)
@ -303,7 +304,7 @@
(let-values ([(w h rows) (gif->rgba-rows in)])
(let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 w h)]
[alpha? #t]
[pre? #f]
[pre? (and alpha? (eq? kind 'gif/alpha))]
[b&w? #f])
(install-bytes-rows s w h rows b&w? alpha? pre? #f)
(values s b&w?)))]
@ -379,19 +380,11 @@
[al (if alpha?
(unsafe-bytes-ref r (fx+ spos 3))
255)]
[a (if pre?
al
255)]
[premult (lambda (al v)
(if pre?
(unsafe-fxquotient (fx* al v) 255)
(if alpha?
(unsafe-fxquotient
(+ (* 255 (- 255 al))
(* v al))
255)
v)))])
(unsafe-bytes-set! dest (fx+ pos A) a)
v))])
(unsafe-bytes-set! dest (fx+ pos A) al)
(unsafe-bytes-set! dest (fx+ pos R) (premult al (unsafe-bytes-ref r spos)))
(unsafe-bytes-set! dest (fx+ pos G) (premult al (unsafe-bytes-ref r (fx+ spos 1))))
(unsafe-bytes-set! dest (fx+ pos B) (premult al (unsafe-bytes-ref r (fx+ spos 2))))))))))
@ -442,7 +435,8 @@
(= height (send loaded-mask get-height)))
(let ([bstr (make-bytes (* width height 4))])
(get-argb-pixels 0 0 width height bstr)
(get-argb-pixels 0 0 width height bstr #t)
(when loaded-mask
(send loaded-mask get-argb-pixels 0 0 width height bstr #t))
;; PNG wants RGBA instead of ARGB...
(let ([rows (build-vector height (lambda (i) (make-bytes (* 4 width))))])
(for ([j (in-range height)]
@ -533,8 +527,8 @@
(bytes-set! bstr (+ p 2) 0)
(bytes-set! bstr (+ p 3) 0))))
;; Get pixels:
(let-values ([(A R G B) (argb-indices)])
(when (not get-alpha?)
(when (not get-alpha?)
(let-values ([(A R G B) (argb-indices)])
(cairo_surface_flush s)
(let ([data (cairo_image_surface_get_data s)]
[row-width (cairo_image_surface_get_stride s)])
@ -559,17 +553,10 @@
(bytes-set! bstr (+ pi 2) (unmult a (bytes-ref data (+ ri G))))
(bytes-set! bstr (+ pi 3) (unmult a (bytes-ref data (+ ri B))))))))))))
(cond
[(and get-alpha?
(not alpha-channel?)
loaded-mask
(= width (send loaded-mask get-width))
(= height (send loaded-mask get-height)))
;; Get alpha from mask bitmap:
(send loaded-mask get-alphas-as-mask x y w h bstr)]
[(and get-alpha? alpha-channel?)
[get-alpha?
(get-alphas-as-mask x y w h bstr)]
[(and (not get-alpha?) (not alpha-channel?))
;; For non-alpha mode or no mask; fill in 255s:
;; For non-alpha mode and no alpha channel; fill in 255s for alpha:
(for ([j (in-range 0 (min h (- height y)))])
(let ([row (* j (* 4 w))])
(for ([i (in-range 0 (min w (- width x)))])

21
collects/racket/draw/png.rkt
View File

@ -131,8 +131,8 @@
(define-png png_write_end (_fun _png_structp _png_infop -> _void))
(define-png png_get_valid (_fun _png_structp _png_infop _uint32 -> _uint32))
(define-png png_get_bKGD (_fun _png_structp _png_infop _png_color_16-pointer -> _bool))
(define-png png_set_background (_fun _png_structp _png_infop _png_color_16-pointer _int _int _double* -> _bool))
(define-png png_get_bKGD (_fun _png_structp _png_infop (p : (_ptr o _png_color_16-pointer)) -> (r : _bool) -> (and r p)))
(define-png png_set_background (_fun _png_structp _png_color_16-pointer _int _int _double* -> _bool))
(define-png png_get_gAMA (_fun _png_structp _png_infop (g : (_ptr o _double))
-> (ok? : _bool)
-> (and ok? g)))
@ -199,7 +199,7 @@
(define free-cell ((deallocator) free-immobile-cell))
(define make-cell ((allocator free-cell) malloc-immobile-cell))
(define (create-png-reader in bg-rgb)
(define (create-png-reader in keep-alpha? bg-rgb)
(let* ([png (png_create_read_struct PNG_LIBPNG_VER_STRING #f error-esc void)]
[info (png_create_info_struct png)]
[ib (make-cell in)])
@ -209,8 +209,9 @@
interlace-type compression-type filter-type)
(png_get_IHDR png info)])
(let* ([tRNS? (positive? (png_get_valid png info PNG_INFO_tRNS))]
[alpha? (or tRNS?
(positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA)))]
[alpha? (and keep-alpha?
(or tRNS?
(positive? (bitwise-ior color-type PNG_COLOR_MASK_ALPHA))))]
[b&w? (and (= depth 1)
(= color-type PNG_COLOR_TYPE_GRAY)
(not tRNS?))])
@ -239,8 +240,14 @@
(set-png_color_16-green! bg (deep (cadr bg-rgb)))
(set-png_color_16-blue! bg (deep (caddr bg-rgb)))
(set-png_color_16-gray! bg (deep (floor (/ (apply + bg-rgb) 3))))]
[else (png_get_bKGD png info bg)])
(png_set_background png info bg PNG_BACKGROUND_GAMMA_SCREEN 0 1.0)))
[else (let ([c (png_get_bKGD png info)])
(when c
(memcpy bg c (ctype-sizeof _png_color_16))))])
(png_set_background png bg
(if bg-rgb
PNG_BACKGROUND_GAMMA_SCREEN
PNG_BACKGROUND_GAMMA_FILE)
0 1.0)))
(let ([gamma (png_get_gAMA png info)])
(when gamma
(let* ([s (getenv "SCREEN_GAMMA")]

2
collects/racket/draw/xbm.rkt
View File

@ -2,7 +2,7 @@
(provide read-xbm)
(define rx:define #rx#"#define[ \t]+[A-Za-z0-9_]+[ \t]+([0-9]+)")
(define rx:define #rx#"#define[ \t]+[-A-Za-z0-9_]+[ \t]+([0-9]+)")
(define rx:byte #rx#"0x([0-9a-fA-F][0-9a-fA-F])")
(define (read-xbm in)