From 439683af5e938a0662139e5af90f65103d8c53cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 1 Aug 2010 06:57:03 -0600 Subject: [PATCH] fixes to bitmap%, especially mask vs. alpha mode --- collects/mred/private/wx/cocoa/image.rkt | 5 ++-- collects/mred/private/wx/cocoa/procs.rkt | 2 +- collects/mred/private/wx/cocoa/queue.rkt | 4 +-- collects/mred/private/wx/gtk/message.rkt | 6 ++-- collects/mred/private/wx/gtk/pixbuf.rkt | 5 ++-- collects/racket/draw/bitmap.rkt | 35 ++++++++---------------- collects/racket/draw/png.rkt | 21 +++++++++----- collects/racket/draw/xbm.rkt | 2 +- 8 files changed, 39 insertions(+), 41 deletions(-) diff --git a/collects/mred/private/wx/cocoa/image.rkt b/collects/mred/private/wx/cocoa/image.rkt index 808b9b4208..4d4de0bdcd 100644 --- a/collects/mred/private/wx/cocoa/image.rkt +++ b/collects/mred/private/wx/cocoa/image.rkt @@ -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)]) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index da4f6ec169..3d7e2c10c5 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -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) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 3211db0590..9e45b71f7a 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -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]) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index fdd2397cf3..b29ba9d164 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -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 ""))))] [no-show? (memq 'deleted style)]) (set-auto-size) diff --git a/collects/mred/private/wx/gtk/pixbuf.rkt b/collects/mred/private/wx/gtk/pixbuf.rkt index d94c74d527..cfcbca4e79 100644 --- a/collects/mred/private/wx/gtk/pixbuf.rkt +++ b/collects/mred/private/wx/gtk/pixbuf.rkt @@ -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)]) diff --git a/collects/racket/draw/bitmap.rkt b/collects/racket/draw/bitmap.rkt index 90edc5e3b1..f25b996ed9 100644 --- a/collects/racket/draw/bitmap.rkt +++ b/collects/racket/draw/bitmap.rkt @@ -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)))]) diff --git a/collects/racket/draw/png.rkt b/collects/racket/draw/png.rkt index 3bbf719e0c..578f21e1b3 100644 --- a/collects/racket/draw/png.rkt +++ b/collects/racket/draw/png.rkt @@ -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")] diff --git a/collects/racket/draw/xbm.rkt b/collects/racket/draw/xbm.rkt index cc8b22d978..3cfcbd8bc9 100644 --- a/collects/racket/draw/xbm.rkt +++ b/collects/racket/draw/xbm.rkt @@ -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)